diff --git a/src/bootsupport/modules/punk-0.1.tm b/src/bootsupport/modules/punk-0.1.tm index 1e09252d..6bf529eb 100644 --- a/src/bootsupport/modules/punk-0.1.tm +++ b/src/bootsupport/modules/punk-0.1.tm @@ -6321,7 +6321,10 @@ namespace eval punk { #useful for aliases e.g treemore -> xmore tree proc xmore {args} { if {[llength $args]} { - uplevel #0 [list {*}$args | more] + #more is older and not as featureful as less + #more importantly - at least some implementations (msys on windows) can skip output lines - unknown as to why + #uplevel #0 [list {*}$args | more] + uplevel #0 [list {*}$args | less -X] ;#-X to avoid use of alternate-screen } else { error "usage: punk::xmore args where args are run as {*}\$args | more" } diff --git a/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/bootsupport/modules/punk/ansi-0.1.1.tm index ad2d58f4..15421402 100644 --- a/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -3130,10 +3130,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } undt { - #CSI 58:5 UNDERLINE COLOR PALETTE INDEX - #CSI 58 : 5 : INDEX m - #variable TERM_colour_map - #256 colour underline by Xterm name or by integer + # CSI 58:5 UNDERLINE COLOR PALETTE INDEX + # CSI 58 : 5 : INDEX m + # variable TERM_colour_map + # 256 colour underline by Xterm name or by integer #name is xterm name or colour index from 0 - 255 set cc [tcl::string::tolower [tcl::string::range $i 5 end]] if {[tcl::string::is integer -strict $cc] & $cc < 256} { @@ -5202,9 +5202,10 @@ tcl::namespace::eval punk::ansi { #tcl::dict::set codestate_empty undersingle "" #tcl::dict::set codestate_empty underdouble "" #tcl::dict::set codestate_empty undercurly "" - #tcl::dict::set codestate_empty underdottedn "" + #tcl::dict::set codestate_empty underdotted "" #tcl::dict::set codestate_empty underdashed "" + tcl::dict::set codestate_empty blink "" ;#5 or 6 for slow/fast, 25 for off tcl::dict::set codestate_empty reverse "" ;#7 on 27 off tcl::dict::set codestate_empty hide "" ;#8 on 28 off @@ -5234,6 +5235,8 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate_empty fg "" ;#30-37 + 90-97 tcl::dict::set codestate_empty bg "" ;#40-47 + 100-107 + variable metastate_empty + tcl::dict::set metastate_empty underline_active "" ;#a meta state for whether underlines are on|off - values 1,0,"" #misnomer should have been sgr_merge_args ? :/ #as a common case optimisation - it will not merge a single element list, even if that code contains redundant elements @@ -5269,6 +5272,7 @@ tcl::namespace::eval punk::ansi { #(use punk::ansi::ta::split_codes_single) proc sgr_merge_singles {codelist args} { variable codestate_empty + variable metastate_empty variable defaultopts_sgr_merge_singles set opts $defaultopts_sgr_merge_singles foreach {k v} $args { @@ -5284,8 +5288,8 @@ tcl::namespace::eval punk::ansi { } set othercodes [list] - set codestate $codestate_empty - set codestate_initial $codestate_empty ;#keep a copy for resets. + set codestate $codestate_empty ;#take copy as we need the empty state for resets + set metastate $metastate_empty set did_reset 0 #we should also handle 8bit CSI here? mixed \x1b\[ and \x9b ? Which should be used in the merged result? @@ -5345,7 +5349,8 @@ tcl::namespace::eval punk::ansi { switch -- $codeint { "" - 0 { if {![tcl::dict::get $opts -filter_reset]} { - set codestate $codestate_initial + set codestate $codestate_empty + set metastate $metastate_empty set did_reset 1 } } @@ -5371,27 +5376,42 @@ tcl::namespace::eval punk::ansi { #e.g hyper on windows if {[llength $paramsplit] == 1} { tcl::dict::set codestate underline 4 + if {[tcl::dict::get $codestate underextended] eq "4:0"} { + tcl::dict::set codestate underextended "" + } + tcl::dict::set metastate underline_active 1 } else { switch -- [lindex $paramsplit 1] { 0 { #no *extended* underline #tcl::dict::set codestate underline 24 tcl::dict::set codestate underextended 4:0 ;#will not turn off SGR standard underline if term doesn't support extended + tcl::dict::set metastate underline_active 0 } 1 { + #single tcl::dict::set codestate underextended 4:1 + tcl::dict::set metastate underline_active 1 } 2 { + #double tcl::dict::set codestate underextended 4:2 + tcl::dict::set metastate underline_active 1 } 3 { + #curly tcl::dict::set codestate underextended "4:3" + tcl::dict::set metastate underline_active 1 } 4 { + #dotted tcl::dict::set codestate underextended "4:4" + tcl::dict::set metastate underline_active 1 } 5 { + #dashed tcl::dict::set codestate underextended "4:5" + tcl::dict::set metastate underline_active 1 } } @@ -5431,6 +5451,7 @@ tcl::namespace::eval punk::ansi { 24 { tcl::dict::set codestate underline 24 ;#off tcl::dict::set codestate underextended "4:0" ;#review + tcl::dict::set metastate underline_active 0 } 25 { tcl::dict::set codestate blink 25 ;#off @@ -5519,11 +5540,11 @@ tcl::namespace::eval punk::ansi { } 58 { #nonstandard - #256 colour or rgb + # 256 colour or rgb if {[tcl::string::first : $p] < 0} { switch -- [lindex $plist $i+1] { 5 { - #256 - 1 more param + # 256 - 1 more param tcl::dict::set codestate underlinecolour "58\;5\;[lindex $plist $i+2]" incr i 2 } @@ -5544,10 +5565,12 @@ tcl::namespace::eval punk::ansi { 60 { tcl::dict::set codestate ideogram_underline 60 tcl::dict::set codestate ideogram_clear "" + #nounderline effect? review! } 61 { tcl::dict::set codestate ideogram_doubleunderline 61 tcl::dict::set codestate ideogram_clear "" + #nounderline effect? review! } 62 { tcl::dict::set codestate ideogram_overline 62 @@ -5566,6 +5589,7 @@ tcl::namespace::eval punk::ansi { #review - we still need to pass through the ideogram_clear in case something understands it tcl::dict::set codestate ideogram_underline "" tcl::dict::set codestate ideogram_doubleunderline "" + tcl::dict::set codestate ideogram_overline "" tcl::dict::set codestate ideogram_doubleoverline "" } @@ -5623,6 +5647,7 @@ tcl::namespace::eval punk::ansi { } } underlinecolour - underextended { + #review append unmergeable "${v}\;" } default { @@ -5640,7 +5665,11 @@ tcl::namespace::eval punk::ansi { "" {} default { switch -- $k { - underlinecolour - underextended { + underlinecolour { + append unmergeable "${v}\;" + } + underextended { + #review append unmergeable "${v}\;" } default { diff --git a/src/bootsupport/modules/punk/args-0.2.tm b/src/bootsupport/modules/punk/args-0.2.tm index 7b6ee228..d8c43c45 100644 --- a/src/bootsupport/modules/punk/args-0.2.tm +++ b/src/bootsupport/modules/punk/args-0.2.tm @@ -3608,7 +3608,12 @@ tcl::namespace::eval punk::args { #A_PREFIX can resolve to empty string if colour off #we then want to display underline instead set A_PREFIX [a+ underline] - set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + #set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space (zwsp) + set A_PREFIXEND [a+ nounderline] + #review - zwsp problematic on older terminals that print it visibly + #- especially if they also lie about cursor position after it's emitted. + #so although the zwsp fixes the issue where the underline extends to rhs padding if all text was underlined, + #It's probably best fixed in the padding functionality. } else { set A_PREFIXEND $RST } diff --git a/src/bootsupport/modules/punk/console-0.1.1.tm b/src/bootsupport/modules/punk/console-0.1.1.tm index 4d4518d3..b8b56d23 100644 --- a/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/bootsupport/modules/punk/console-0.1.1.tm @@ -211,9 +211,9 @@ namespace eval punk::console { set result [dict create] if {"output" in $channels} { #note setting stdout makes stderr have the same settings - ie there is really only one output to configure - set h_out [twapi::get_console_handle stdout] + set h_out [twapi::get_console_handle stdout] set oldmode [twapi::GetConsoleMode $h_out] - set newmode [expr {$oldmode | 4}] + set newmode [expr {$oldmode | 4}] twapi::SetConsoleMode $h_out $newmode dict set result output [list from $oldmode to $newmode] } @@ -255,7 +255,7 @@ namespace eval punk::console { #as above - configuring stdout does stderr too set h_out [twapi::get_console_handle stdout] set oldmode [twapi::GetConsoleMode $h_out] - set newmode [expr {$oldmode & ~4}] + set newmode [expr {$oldmode & ~4}] twapi::SetConsoleMode $h_out $newmode dict set result output [list from $oldmode to $newmode] } @@ -412,7 +412,7 @@ namespace eval punk::console { } if {$wrote} { tsv::set console is_raw 1 - after 100 + #after 100 close $pipe } else { puts stderr "write to $ps_pipename failed trynum: $trynum\n$errMsg" diff --git a/src/bootsupport/modules/punk/mix/cli-0.3.1.tm b/src/bootsupport/modules/punk/mix/cli-0.3.1.tm index 17c9918b..ad60b069 100644 --- a/src/bootsupport/modules/punk/mix/cli-0.3.1.tm +++ b/src/bootsupport/modules/punk/mix/cli-0.3.1.tm @@ -507,6 +507,7 @@ namespace eval punk::mix::cli { -punkcheck_eventobj "\uFFFF"\ -glob *.tm\ -podglob #modpod-*\ + -tarjarglob #tarjar-*\ ] set opts [dict merge $defaults $args] @@ -519,6 +520,7 @@ namespace eval punk::mix::cli { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set fileglob [dict get $opts -glob] set podglob [dict get $opts -podglob] + set tarjarglob [dict get $opts -tarjarglob] if {![string match "*.tm" $fileglob]} { error "build_modules_from_source_to_base -glob '$fileglob' doesn't seem to target tcl modules." } @@ -580,6 +582,10 @@ namespace eval punk::mix::cli { foreach podpath $src_pods { dict set process_modules $podpath [dict create -type pod] } + set src_tarjars [glob -nocomplain -dir $current_source_dir -type d -tail $tarjarglob] + foreach tarjarpath $src_tarjars { + dict set process_modules $tarjarpath [dict create -type tarjar] + } 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] @@ -801,8 +807,173 @@ namespace eval punk::mix::cli { } } tarjar { + #maint - overall code structure same as pod - refactor? #basename may still contain #tarjar- #to be obsoleted - update modpod to (optionally) use vfs::tar ? + if {[string match #tarjar-* $basename]} { + set basename [string range $basename 8 end] + } else { + error "build_modules_from_source_to_base, tarjar, unexpected basename $basename" ;#shouldn't be possible with default tarjarglob - review - why is tarjarglob 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\ + ] + set had_error 0 + + # -max_depth -1 for no limit + set build_installername tarjars_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/#tarjar-$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/#tarjar-$basename-$module_build_version/#tarjar-loadscript-$basename.tcl + #we don't need to modify version or name of the loadscript + #just do basic sanity check that the file exists + if {![file exists $tmfile]} { + set had_error 1 + lappend notes "tarjar_loadscript_missing" + } + } + #delete and regenerate .tm + set notes [list] + if {[catch { + file delete $buildfolder/$basename-$module_build_version.tm + } err]} { + set had_error 1 + lappend notes "tm_delete_failed" + } + #create ordinary tar file without using external executable + package require tar ;#tcllib + set tarfile $buildfolder/$basename-$module_build_version.tm ;#ordinary tar file (no compression - store) + set wd [pwd] + cd $buildfolder + puts "tar::create $tarfile #tarjar-$basename-$module_build_version" + if {[catch { + tar::create $tarfile #tarjar-$basename-$module_build_version + } errMsg]} { + set had_error 1 + puts stderr "tar::create $tarfile failed with msg\n $errMsg" + lappend notes "tar_create_failed" + } + cd $wd + + if {![file exists $tarfile]} { + set had_error 1 + lappend notes "tar_result_missing" + } + + + 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 "T" + 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 + + #JMN - review + if {!$had_error} { + $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 + if {[catch { + file copy -force $modulefile $target_module_dir + } errMsg]} { + puts stderr "FAILED to copy tarjar module $modulefile to $target_module_dir" + $event targetset_end FAILED -note "could not copy $modulefile" + } else { + puts stderr "Copied tarjar module $modulefile to $target_module_dir" + # -- --- --- --- --- --- + $event targetset_end OK -note "tarjar" + } + } else { + puts -nonewline stderr "t" + set did_skip 1 + if {$is_interesting} { + puts stderr "$modulefile [$event targetset_source_changes]" + } + $event targetset_end SKIPPED + } + } } file { @@ -829,39 +1000,40 @@ namespace eval punk::mix::cli { if {[file exists $current_source_dir/#tarjar-$basename-$magicversion]} { - #rebuild the .tm from the #tarjar + #rebuilding the .tm from the #tarjar already handled above + puts -nonewline stderr "-" - if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} { + #if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} { - } else { + #} else { - } - #REVIEW - should be in same structure/depth as $target_module_dir in _build? + #} + ##REVIEW - should be in same structure/depth as $target_module_dir in _build? - #TODO - set buildfolder $current_sourcedir/_build - file mkdir $buildfolder + ##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 + #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 + #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 + #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}#]} { diff --git a/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/bootsupport/modules/punk/ns-0.1.0.tm index e899a401..3de09e5e 100644 --- a/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -73,7 +73,7 @@ tcl::namespace::eval punk::ns { set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $ns_current *]] } else { set is_absolute [string match ::* $ns_or_glob] - set has_globchars [regexp {[*?]} $ns_or_glob] + set has_globchars [regexp {[*?]} $ns_or_glob] ;#basic globs only? if {$is_absolute} { if {!$has_globchars} { if {![nsexists $ns_or_glob]} { @@ -747,7 +747,13 @@ tcl::namespace::eval punk::ns { return $nslist } - variable usageinfo_char \U1f6c8 + #The information symbol - usually i in a circle + #punkargs " symbol \U1f6c8" ;#problematic on terminals that lie about cursor position after emitting this character + #The older \u2139 could be used - but it is sometimes a boxed i, sometimes a bold stylized i, sometimes a pre-coloured boxed i + #\u24d8 (circled latein small letter i) seems more consistent and can have our own colour applied. + #variable usageinfo_char \U1f6c8 + variable usageinfo_char \u24d8 + # command has usageinfo e.g from punk::args. todo cmdline, argp, tepam etc? proc Usageinfo_mark {{ansicodes \UFFEF}} { variable usageinfo_char @@ -760,6 +766,7 @@ tcl::namespace::eval punk::ns { } } + punk::args::define { @id -id ::punk::ns::Cmark @cmd -name punk::ns::Cmark @@ -768,7 +775,7 @@ tcl::namespace::eval punk::ns { oo " symbol \u25c6" ooc " symbol \u25c7" ooo " symbol \u25c8" - punkargs " symbol \U1f6c8" + punkargs " symbol \u24d8" ensemble " symbol \u24ba" native " symbol \u24c3" unknown " symbol \u2370" @@ -797,7 +804,7 @@ tcl::namespace::eval punk::ns { return; #should be unreachable - parse should raise usage error } } - set marks [dict create oo \u25c6 ooc \u25c7 ooo \u25c8 punkargs \U1f6c8 ensemble \u24ba native \u24c3 unknown \U2370] + set marks [dict create oo \u25c6 ooc \u25c7 ooo \u25c8 punkargs \u24d8 ensemble \u24ba native \u24c3 unknown \U2370] if {[llength $ansinames]} { return "[punk::ansi::a+ {*}$ansinames][dict get $marks $type]\x1b\[0m" } else { diff --git a/src/bootsupport/modules/punk/repl-0.1.2.tm b/src/bootsupport/modules/punk/repl-0.1.2.tm index 11cd9706..7d93d529 100644 --- a/src/bootsupport/modules/punk/repl-0.1.2.tm +++ b/src/bootsupport/modules/punk/repl-0.1.2.tm @@ -1876,7 +1876,9 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #ctrl-c if {$chunk eq "\x03"} { #::punk::repl::handler_console_control "ctrl-c_via_rawloop" - error "character 03 -> ctrl-c" + puts stderr "ctrl-c via rawloop - not signal" + ::punk::repl::handler_console_control ctrl-c via_rawloop + #error "character 03 -> ctrl-c" } if {$chunk eq "\x7f"} { @@ -1898,8 +1900,9 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #for now - exit with small delay for tidyup #ctrl-z #::punk::repl::handler_console_control "ctrl-z_via_rawloop" - if {[catch {mode line}]} { - interp eval code {mode line} + if {[catch {punk::console::mode line}]} { + #REVIEW + interp eval code {punk::console::mode line} } after 1000 {exit 43} return diff --git a/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/bootsupport/modules/punk/repo-0.1.1.tm index 2ab1fb01..5d2a2725 100644 --- a/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -92,6 +92,9 @@ namespace eval punk::repo { } lappend maincommands {*}$ln } + #fossil output was ordered in columns, but we loaded list in row-wise, messing up the order + set maincommands [lsort $maincommands] + set allcmds [lsort $allcmds] set othercmds [punk::lib::ldiff $allcmds $maincommands] set result "@leaders -min 0\n" diff --git a/src/bootsupport/modules/shellrun-0.1.1.tm b/src/bootsupport/modules/shellrun-0.1.1.tm index 8f03892d..478c70fa 100644 --- a/src/bootsupport/modules/shellrun-0.1.1.tm +++ b/src/bootsupport/modules/shellrun-0.1.1.tm @@ -222,6 +222,9 @@ namespace eval shellrun { } set resolved_cmdname [auto_execok $cmdname] + if {$resolved_cmdname eq ""} { + error "Cannot find path for executable '$cmdname'" + } set repl_runid [punk::get_repl_runid] #set ::punk::last_run_display [list] diff --git a/src/decktemplates/custom/_project/layout_refs/@custom+_project+punk.project-0.1.ref b/src/decktemplates/custom/_project/layout_refs/@vendor+punk+sample-0.1.ref similarity index 100% rename from src/decktemplates/custom/_project/layout_refs/@custom+_project+punk.project-0.1.ref rename to src/decktemplates/custom/_project/layout_refs/@vendor+punk+sample-0.1.ref diff --git a/src/decktemplates/custom/_project/layout_refs/@custom+_project+punk.shell-0.1.ref b/src/decktemplates/custom/_project/layout_refs/punk.project-0.1_overrides@custom+_project+punk.project-0.1.ref similarity index 100% rename from src/decktemplates/custom/_project/layout_refs/@custom+_project+punk.shell-0.1.ref rename to src/decktemplates/custom/_project/layout_refs/punk.project-0.1_overrides@custom+_project+punk.project-0.1.ref diff --git a/src/decktemplates/custom/_project/layout_refs/test1@vendor+punk+sample-0.1.ref b/src/decktemplates/custom/_project/layout_refs/punk.shell-0.1_overrides@custom+_project+punk.shell-0.1.ref similarity index 100% rename from src/decktemplates/custom/_project/layout_refs/test1@vendor+punk+sample-0.1.ref rename to src/decktemplates/custom/_project/layout_refs/punk.shell-0.1_overrides@custom+_project+punk.shell-0.1.ref diff --git a/src/decktemplates/vendor/punk/layout_refs/project@vendor+punk+project-0.1.refXXX b/src/decktemplates/vendor/punk/layout_refs/@vendor+punk+project-0.1.ref similarity index 100% rename from src/decktemplates/vendor/punk/layout_refs/project@vendor+punk+project-0.1.refXXX rename to src/decktemplates/vendor/punk/layout_refs/@vendor+punk+project-0.1.ref diff --git a/src/make.tcl b/src/make.tcl index c1d3f906..858c0d2d 100644 --- a/src/make.tcl +++ b/src/make.tcl @@ -1263,6 +1263,8 @@ proc ::punkboot::punkboot_gethelp {args} { append h " - show the name and base folder of the project to be built" \n \n append h " $scriptname check" \n append h " - show module/library paths and any potentially problematic packages for running this script" \n + append h " $scriptname shell" \n + append h " - run the punk shell using bootsupport libraries." \n append h "" \n if {[llength [dict get $pkg_availability missing]] || [llength [dict get $pkg_availability broken]]} { set has_recommended 0 @@ -1331,8 +1333,9 @@ punk::args::define { subcommand -type "literal(shell)" arg -type any -optional 1 -multiple 1 } + #set argd [punk::args::parse $scriptargs -form 0 withid punkmake] -##lassign [dict values $argd] leaders opts values received +###lassign [dict values $argd] leaders opts values received # #puts stdout [punk::args::usage -scheme nocolour punkmake] #exit 1 diff --git a/src/project_layouts/custom/_project/punk.basic/src/make.tcl b/src/project_layouts/custom/_project/punk.basic/src/make.tcl index c1d3f906..858c0d2d 100644 --- a/src/project_layouts/custom/_project/punk.basic/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.basic/src/make.tcl @@ -1263,6 +1263,8 @@ proc ::punkboot::punkboot_gethelp {args} { append h " - show the name and base folder of the project to be built" \n \n append h " $scriptname check" \n append h " - show module/library paths and any potentially problematic packages for running this script" \n + append h " $scriptname shell" \n + append h " - run the punk shell using bootsupport libraries." \n append h "" \n if {[llength [dict get $pkg_availability missing]] || [llength [dict get $pkg_availability broken]]} { set has_recommended 0 @@ -1331,8 +1333,9 @@ punk::args::define { subcommand -type "literal(shell)" arg -type any -optional 1 -multiple 1 } + #set argd [punk::args::parse $scriptargs -form 0 withid punkmake] -##lassign [dict values $argd] leaders opts values received +###lassign [dict values $argd] leaders opts values received # #puts stdout [punk::args::usage -scheme nocolour punkmake] #exit 1 diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/dictn-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/dictn-0.1.1.tm deleted file mode 100644 index c9ef87f2..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/dictn-0.1.1.tm +++ /dev/null @@ -1,349 +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) 2023 -# -# @@ Meta Begin -# Application dictn 0.1.1 -# Meta platform tcl -# Meta license -# @@ Meta End - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -##e.g package require frobz - - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval dictn { - namespace export {[a-z]*} - namespace ensemble create -} - - -## ::dictn::append -#This can of course 'ruin' a nested dict if applied to the wrong element -# - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl: -# %set list {a b {c d}} -# %append list x -# a b {c d}x -# IOW - don't do that unless you really know that's what you want. -# -proc ::dictn::append {dictvar path {value {}}} { - if {[llength $path] == 1} { - uplevel 1 [list dict append $dictvar $path $value] - } else { - upvar 1 $dictvar dvar - - ::set str [dict get $dvar {*}$path] - append str $val - dict set dvar {*}$path $str - } -} - -proc ::dictn::create {args} { - ::set data {} - foreach {path val} $args { - dict set data {*}$path $val - } - return $data -} - -proc ::dictn::exists {dictval path} { - return [dict exists $dictval {*}$path] -} - -proc ::dictn::filter {dictval path filterType args} { - ::set sub [dict get $dictval {*}$path] - dict filter $sub $filterType {*}$args -} - -proc ::dictn::for {keyvalvars dictval path body} { - ::set sub [dict get $dictval {*}$path] - dict for $keyvalvars $sub $body -} - -proc ::dictn::get {dictval {path {}}} { - return [dict get $dictval {*}$path] -} - -proc ::dictn::getdef {dictval path default} { - return [dict getdef $dictval {*}$path $default] -} - -proc ::dictn::getwithdefault {dictval path default} { - return [dict getdef $dictval {*}$path $default] -} - -if {[info commands ::tcl::dict::getdef] ne ""} { - proc ::dictn::incr {dictvar path {increment {}} } { - if {$increment eq ""} { - ::set increment 1 - } - if {[llength $path] == 1} { - uplevel 1 [list dict incr $dictvar $path $increment] - } else { - upvar 1 $dictvar dvar - if {![::info exists dvar]} { - dict set dvar {*}$path $increment - } else { - ::set newval [expr {[dict getdef $dvar {*}$path 0] + $increment}] - dict set dvar {*}$path $newval - } - return $dvar - } - } -} else { - proc ::dictn::incr {dictvar path {increment {}} } { - if {$increment eq ""} { - ::set increment 1 - } - if {[llength $path] == 1} { - uplevel 1 [list dict incr $dictvar $path $increment] - } else { - upvar 1 $dictvar dvar - if {![::info exists dvar]} { - dict set dvar {*}$path $increment - } else { - if {![dict exists $dvar {*}$path]} { - ::set val 0 - } else { - ::set val [dict get $dvar {*}$path] - } - ::set newval [expr {$val + $increment}] - dict set dvar {*}$path $newval - } - return $dvar - } - } -} - -proc ::dictn::info {dictval {path {}}} { - if {![string length $path]} { - return [dict info $dictval] - } else { - ::set sub [dict get $dictval {*}$path] - return [dict info $sub] - } -} - -proc ::dictn::keys {dictval {path {}} {glob {}}} { - ::set sub [dict get $dictval {*}$path] - if {[string length $glob]} { - return [dict keys $sub $glob] - } else { - return [dict keys $sub] - } -} - -proc ::dictn::lappend {dictvar path args} { - if {[llength $path] == 1} { - uplevel 1 [list dict lappend $dictvar $path {*}$args] - } else { - upvar 1 $dictvar dvar - - ::set list [dict get $dvar {*}$path] - ::lappend list {*}$args - dict set dvar {*}$path $list - } -} - -proc ::dictn::merge {args} { - error "nested merge not yet supported" -} - -#dictn remove dictionaryValue ?path ...? -proc ::dictn::remove {dictval args} { - ::set basic [list] ;#buffer basic (1element path) removals to do in a single call. - - foreach path $args { - if {[llength $path] == 1} { - ::lappend basic $path - } else { - #extract,modify,replace - ::set subpath [lrange $path 0 end-1] - - ::set sub [dict get $dictval {*}$subpath] - ::set sub [dict remove $sub [lindex $path end]] - - dict set dictval {*}$subpath $sub - } - } - - if {[llength $basic]} { - return [dict remove $dictval {*}$basic] - } else { - return $dictval - } -} - - -proc ::dictn::replace {dictval args} { - ::set basic [list] ;#buffer basic (1element path) replacements to do in a single call. - - foreach {path val} $args { - if {[llength $path] == 1} { - ::lappend basic $path $val - } else { - #extract,modify,replace - ::set subpath [lrange $path 0 end-1] - - ::set sub [dict get $dictval {*}$subpath] - ::set sub [dict replace $sub [lindex $path end] $val] - - dict set dictval {*}$subpath $sub - } - } - - - if {[llength $basic]} { - return [dict replace $dictval {*}$basic] - } else { - return $dictval - } -} - - -proc ::dictn::set {dictvar path newval} { - upvar 1 $dictvar dvar - return [dict set dvar {*}$path $newval] -} - -proc ::dictn::size {dictval {path {}}} { - return [dict size [dict get $dictval {*}$path]] -} - -proc ::dictn::unset {dictvar path} { - upvar 1 $dictvar dvar - return [dict unset dvar {*}$path -} - -proc ::dictn::update {dictvar args} { - ::set body [lindex $args end] - ::set maplist [lrange $args 0 end-1] - - upvar 1 $dictvar dvar - foreach {path var} $maplist { - if {[dict exists $dvar {*}$path]} { - uplevel 1 [list set $var [dict get $dvar $path]] - } - } - - catch {uplevel 1 $body} result - - foreach {path var} $maplist { - if {[dict exists $dvar {*}$path]} { - upvar 1 $var $var - if {![::info exists $var]} { - uplevel 1 [list dict unset $dictvar {*}$path] - } else { - uplevel 1 [list dict set $dictvar {*}$path [::set $var]] - } - } - } - return $result -} - -#an experiment. -proc ::dictn::Applyupdate {dictvar args} { - ::set body [lindex $args end] - ::set maplist [lrange $args 0 end-1] - - upvar 1 $dictvar dvar - - ::set headscript "" - ::set i 0 - foreach {path var} $maplist { - if {[dict exists $dvar {*}$path]} { - #uplevel 1 [list set $var [dict get $dvar $path]] - ::lappend arglist $var - ::lappend vallist [dict get $dvar {*}$path] - ::append headscript [string map [list %i% $i %v% $var] {upvar 1 %v% %v%; set %v% [lindex $args %i%]} ] - ::append headscript \n - ::incr i - } - } - - ::set body $headscript\r\n$body - - puts stderr "BODY: $body" - - #set result [apply [list args $body] {*}$vallist] - catch {apply [list args $body] {*}$vallist} result - - foreach {path var} $maplist { - if {[dict exists $dvar {*}$path] && [::info exists $var]} { - dict set dvar {*}$path [::set $var] - } - } - return $result -} - -proc ::dictn::values {dictval {path {}} {glob {}}} { - ::set sub [dict get $dictval {*}$path] - if {[string length $glob]} { - return [dict values $sub $glob] - } else { - return [dict values $sub] - } -} - -# Standard form: -#'dictn with dictVariable path body' -# -# Extended form: -#'dictn with dictVariable path arrayVariable body' -# -proc ::dictn::with {dictvar path args} { - if {[llength $args] == 1} { - ::set body [lindex $args 0] - return [uplevel 1 [list dict with $dictvar {*}$path $body]] - } else { - upvar 1 $dictvar dvar - ::lassign $args arrayname body - - upvar 1 $arrayname arr - array set arr [dict get $dvar {*}$path] - ::set prevkeys [array names arr] - - catch {uplevel 1 $body} result - - - foreach k $prevkeys { - if {![::info exists arr($k)]} { - dict unset $dvar {*}$path $k - } - } - foreach k [array names arr] { - dict set $dvar {*}$path $k $arr($k) - } - - return $result - } -} - - - - - - - - - - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide dictn [namespace eval dictn { - variable version - ::set version 0.1.1 -}] -return \ No newline at end of file diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.2.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.2.tm deleted file mode 100644 index aa27ebce..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.2.tm +++ /dev/null @@ -1,702 +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) 2024 -# -# @@ Meta Begin -# Application modpod 0.1.2 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin modpod_module_modpod 0 0.1.2] -#[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" - #} - - #old tar connect mechanism - review - not needed? - proc connect {args} { - puts stderr "modpod::connect--->>$args" - set argd [punk::args::get_dict { - @id -id ::modpod::connect - -type -default "" - @values -min 1 -max 1 - path -type string -minsize 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 - #//review - set modpod [::modpod::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 - } - } - - #zipfile is a pure zip at this point - ie no script/exe header - proc make_zip_modpod {args} { - set argd [punk::args::get_dict { - @id -id ::modpod::lib::make_zip_modpod - -offsettype -default "archive" -choices {archive file} -help\ - "Whether zip offsets are relative to start of file or start of zip-data within the file. - 'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip, - but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip) - info-zip's 'zip -A' can sometimes convert archive-relative to file-relative. - -offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'" - @values -min 2 -max 2 - zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" - outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" - } $args] - set zipfile [dict get $argd values zipfile] - set outfile [dict get $argd values outfile] - set opt_offsettype [dict get $argd opts -offsettype] - - - set mount_stub [string map [list %offsettype% $opt_offsettype] { - #zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. - #Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. - #generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% - 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 properly 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 windows platform for non-existance) - #This is presumably related to // being interpreted as a network path - 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 - if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { - puts stderr "modpod stub>>> tcl::zipfs::mount failed.\nbut old api: tcl::zipfs::mount succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" - puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" - } - } - if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { - puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n 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 (and zipfs not available either)" - append msg \n "If neither zipfs or vfs::zip are available - 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 $modfile" - error $msg - } else { - 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 supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating? - append mount_stub \x1A - modpod::system::make_mountable_zip $zipfile $outfile $mount_stub $opt_offsettype - - } - - #*** !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 - - #zipfile here is plain zip - no script/exe prefix part. - proc make_mountable_zip {zipfile outfile mount_stub {offsettype "archive"}} { - set inzip [open $zipfile r] - fconfigure $inzip -encoding iso8859-1 -translation binary - set out [open $outfile w+] - fconfigure $out -encoding iso8859-1 -translation binary - puts -nonewline $out $mount_stub - set stuboffset [tell $out] - lappend report "stub size: $stuboffset" - fcopy $inzip $out - close $inzip - - set size [tell $out] - lappend report "tmfile : [file tail $outfile]" - lappend report "output size : $size" - lappend report "offsettype : $offsettype" - - if {$offsettype eq "file"} { - #make zip offsets relative to start of whole file including prepended script. - #same offset structure as Tcl's 'zipfs mkimg' as at 2024-10 - #not editable by 7z,nanazip,peazip - - #we aren't adding any new files/folders so we can edit the offsets in place - - #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 tailsearch_start 0 - } else { - set tailsearch_start [expr {$size - 65559}] - } - seek $out $tailsearch_start - set data [read $out] - #EOCD - End of Central Directory record - #PK\5\6 - 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 - set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] - - lappend report "kitfile-relative START-OF-EOCD: $filerelative_eocd_posn" - - seek $out $filerelative_eocd_posn - 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 {$filerelative_eocd_posn+16}] - - #adjust offset of start of central directory by the length of our sfx stub - puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $stuboffset}]] - flush $out - - seek $out $filerelative_eocd_posn - 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)" - - #PK\1\2 - #33639248 dec = 0x02014b50 - central directory 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)+$stuboffset}]] - - #verify: - flush $out - seek $out $current_file - set fileheader [read $out 46] - lappend report "old $x(offset) + $stuboffset" - 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.2 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/oolib-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/oolib-0.1.tm deleted file mode 100644 index 3756fceb..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/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/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.6.5.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.6.5.tm deleted file mode 100644 index 9363fb6d..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.6.5.tm +++ /dev/null @@ -1,4773 +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.5 -# Meta platform tcl -# Meta license BSD -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[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 --}] -#[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] - -#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. - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !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 tcl::string::range -# - need to extract and replace ansi codes? - -tcl::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 "..." - tcl::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" -} - -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{|}~). - 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 [tcl::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::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::ansistrip. Alternatively try punk::ansi::printing_length" - set text [punk::ansi::ansistrip $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) -tcl::namespace::eval overtype::priv { -} - -#could return larger than renderwidth -proc _get_row_append_column {row} { - #obsolete? - upvar outputlines outputlines - set idx [expr {$row -1}] - if {$row <= 1 || $row > [llength $outputlines]} { - return 1 - } else { - upvar opt_expand_right expand_right - upvar renderwidth renderwidth - set existinglen [punk::ansi::printing_length [lindex $outputlines $idx]] - set endpos [expr {$existinglen +1}] - if {$expand_right} { - return $endpos - } else { - if {$endpos > $renderwidth} { - return $renderwidth + 1 - } else { - return $endpos - } - } - } -} - -tcl::namespace::eval overtype { - #*** !doctools - #[subsection {Namespace overtype}] - #[para] Core API functions for overtype - #[list_begin definitions] - - - - #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. - #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 renderspace {args} { - #*** !doctools - #[call [fun overtype::renderspace] [arg args] ] - #[para] usage: ?-transparent [lb]0|1[rb]? ?-expand_right [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: ?-width ? ?-startcolumn ? ?-transparent [0|1|]? ?-expand_right [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} - } - set optargs [lrange $args 0 end-2] - if {[llength $optargs] % 2 == 0} { - set overblock [lindex $args end] - set underblock [lindex $args end-1] - #lassign [lrange $args end-1 end] underblock overblock - set argsflags [lrange $args 0 end-2] - } else { - set optargs [lrange $args 0 end-1] - if {[llength $optargs] %2 == 0} { - set overblock [lindex $args end] - set underblock "" - set argsflags [lrange $args 0 end-1] - } else { - error "renderspace expects opt-val pairs followed by: or just " - } - } - set opts [tcl::dict::create\ - -bias ignored\ - -width \uFFEF\ - -height \uFFEF\ - -startcolumn 1\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -expand_right 0\ - -appendlines 1\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -experimental 0\ - -cp437 0\ - -looplimit \uFFEF\ - -crm_mode 0\ - -reverse_mode 0\ - -insert_mode 0\ - -wrap 0\ - -info 0\ - -console {stdin stdout stderr}\ - ] - #expand_right is perhaps consistent with the idea of the page_size being allowed to grow horizontally.. - # it does not necessarily mean the viewport grows. (which further implies need for horizontal scrolling) - # - it does need to be within some concept of terminal width - as columns must be addressable by ansi sequences. - # - This implies the -width option value must grow if it is tied to the concept of renderspace terminal width! REVIEW. - # - further implication is that if expand_right grows the virtual renderspace terminal width - - # then some sort of reflow/rerender needs to be done for preceeding lines? - # possibly not - as expand_right is distinct from a normal terminal-width change event, - # expand_right being primarily to support other operations such as textblock::table - - #todo - viewport width/height as separate concept to terminal width/height? - #-ellipsis args not used if -wrap is true - foreach {k v} $argsflags { - switch -- $k { - -looplimit - -width - -height - -startcolumn - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - - -transparent - -exposed1 - -exposed2 - -experimental - - -expand_right - -appendlines - - -reverse_mode - -crm_mode - -insert_mode - - -cp437 - - -info - -console { - tcl::dict::set opts $k $v - } - -wrap - -autowrap_mode { - #temp alias -autowrap_mode for consistency with renderline - #todo - - tcl::dict::set opts -wrap $v - } - default { - error "overtype::renderspace unknown option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - #set opts [tcl::dict::merge $defaults $argsflags] - # -- --- --- --- --- --- - #review - expand_left for RTL text? - set opt_expand_right [tcl::dict::get $opts -expand_right] - #for repl - standard output line indicator is a dash - todo, add a different indicator for a continued line. - 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 - # -- --- --- --- --- --- - set opt_crm_mode [tcl::dict::get $opts -crm_mode] - set opt_reverse_mode [tcl::dict::get $opts -reverse_mode] - set opt_insert_mode [tcl::dict::get $opts -insert_mode] - ##### - # review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?. - set opt_autowrap_mode [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) - ##### - # -- --- --- --- --- --- - set opt_cp437 [tcl::dict::get $opts -cp437] - set opt_info [tcl::dict::get $opts -info] - - - - # ---------------------------- - # -experimental dev flag to set flags etc - # ---------------------------- - set data_mode 0 - set edit_mode 0 - set opt_experimental [tcl::dict::get $opts -experimental] - foreach o $opt_experimental { - switch -- $o { - data_mode { - set data_mode 1 - } - edit_mode { - set edit_mode 1 - } - } - } - # ---------------------------- - - - set underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - - #set underlines [split $underblock \n] - - #underblock is a 'rendered' block - so width height make sense - #only non-cursor affecting and non-width occupying ANSI codes should be present. - #ie SGR codes and perhaps things such as PM - although generally those should have been pushed to the application already - #renderwidth & renderheight were originally used with reference to rendering into a 'column' of output e.g a table column - before cursor row/col was implemented. - - if {$opt_width eq "\uFFEF" || $opt_height eq "\uFFEF"} { - lassign [blocksize $underblock] _w renderwidth _h renderheight - if {$opt_width ne "\uFFEF"} { - set renderwidth $opt_width - } - if {$opt_height ne "\uFFEF"} { - set renderheight $opt_height - } - } else { - set renderwidth $opt_width - set renderheight $opt_height - } - #initial state for renderspace 'terminal' reset - set initial_state [dict create\ - renderwidth $renderwidth\ - renderheight $renderheight\ - crm_mode $opt_crm_mode\ - reverse_mode $opt_reverse_mode\ - insert_mode $opt_insert_mode\ - autowrap_mode $opt_autowrap_mode\ - cp437 $opt_cp437\ - ] - #modes - #e.g insert_mode can be toggled by insert key or ansi IRM sequence CSI 4 h|l - #opt_startcolumn ?? - DECSLRM ? - set vtstate $initial_state - - # -- --- --- --- - #REVIEW - do we need ansi resets in the underblock? - if {$underblock eq ""} { - set underlines [lrepeat $renderheight ""] - } else { - set underblock [textblock::join_basic -- $underblock] ;#ensure properly rendered - ansi per-line resets & replays - set underlines [split $underblock \n] - } - #if {$underblock eq ""} { - # set blank "\x1b\[0m\x1b\[0m" - # #set underlines [list "\x1b\[0m\x1b\[0m"] - # set underlines [lrepeat $renderheight $blank] - #} else { - # #lines_as_list -ansiresets 1 will do nothing if -ansiresets 1 isn't specified - REVIEW - # 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 renderwidth - #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 [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 {[tcl::string::length $overblock] + 10}] - } - - #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 scheme 4 - 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 [tcl::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 [tcl::string::range [lindex $lflines end] 0 end-1] - } - #set inputchunks $lflines[unset lflines] - set inputchunks [lindex [list $lflines [unset lflines]] 0] - - } - 4 { - set inputchunks [list] - foreach ln [split $overblock \n] { - lappend inputchunks $ln\n - } - if {[llength $inputchunks]} { - lset inputchunks end [tcl::string::range [lindex $inputchunks end] 0 end-1] - } - } - } - - - - - set replay_codes_underlay [tcl::dict::create 1 ""] - #lappend replay_codes_overlay "" - set replay_codes_overlay "[punk::ansi::a]" - set unapplied "" - set cursor_saved_position [tcl::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 $opt_startcolumn - #} - - set instruction_stats [tcl::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 {![tcl::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 [tcl::string::cat [lindex $replay_codes_overlay $overidx] $overtext] - set overtext $replay_codes_overlay$overtext - if {[tcl::dict::exists $replay_codes_underlay $row]} { - set undertext [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 - set renderopts [list -experimental $opt_experimental\ - -cp437 $opt_cp437\ - -info 1\ - -crm_mode [tcl::dict::get $vtstate crm_mode]\ - -insert_mode [tcl::dict::get $vtstate insert_mode]\ - -autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\ - -reverse_mode [tcl::dict::get $vtstate reverse_mode]\ - -cursor_restore_attributes $cursor_saved_attributes\ - -transparent $opt_transparent\ - -width [tcl::dict::get $vtstate renderwidth]\ - -exposed1 $opt_exposed1\ - -exposed2 $opt_exposed2\ - -expand_right $opt_expand_right\ - -cursor_column $col\ - -cursor_row $row\ - ] - set rinfo [renderline {*}$renderopts $undertext $overtext] - - set instruction [tcl::dict::get $rinfo instruction] - tcl::dict::set vtstate crm_mode [tcl::dict::get $rinfo crm_mode] - tcl::dict::set vtstate insert_mode [tcl::dict::get $rinfo insert_mode] - tcl::dict::set vtstate autowrap_mode [tcl::dict::get $rinfo autowrap_mode] ;# - tcl::dict::set vtstate reverse_mode [tcl::dict::get $rinfo reverse_mode] - #how to support reverse_mode in rendered linelist? we need to examine all pt/code blocks and flip each SGR stack? - # - review - the answer is probably that we don't need to - it is set/reset only during application of overtext - - #Note carefully the difference betw overflow_right and unapplied. - #overflow_right may need to be included in next run before the unapplied data - #overflow_right most commonly has data when in insert_mode - 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] ;#column width of what is 'rendered' for the line - 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] - if {0 && [tcl::dict::get $vtstate reverse_mode]} { - #test branch - todo - prune - puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered" - #review - #JMN3 - set existing_reverse_state 0 - #split_codes_single is single esc sequence - but could have multiple sgr codes within one esc sequence - #e.g \x1b\[0;31;7m has a reset,colour red and reverse - set codeinfo [punk::ansi::codetype::sgr_merge [list $replay_codes_overlay] -info 1] - set codestate_reverse [dict get $codeinfo codestate reverse] - switch -- $codestate_reverse { - 7 { - set existing_reverse_state 1 - } - 27 { - set existing_reverse_state 0 - } - "" { - } - } - if {$existing_reverse_state == 0} { - set rflip [a+ reverse] - } else { - #reverse of reverse - set rflip [a+ noreverse] - } - #note that mergeresult can have multiple esc (due to unmergeables or non sgr codes) - set replay_codes_overlay [punk::ansi::codetype::sgr_merge [list [dict get $codeinfo mergeresult] $rflip]] - puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered" - } - - - - #-- todo - detect looping properly - if {$row > 1 && $overtext ne "" && $unapplied eq $overtext && $post_render_row == $row && $instruction eq ""} { - puts stderr "overtype::renderspace loop?" - puts [ansistring VIEW $rinfo] - break - } - #-- - - if {[tcl::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 - set instruction_type [lindex $instruction 0] ;#some instructions have params - tcl::dict::incr instruction_stats $instruction_type - switch -- $instruction_type { - reset { - #reset the 'renderspace terminal' (not underlying terminal) - set row 1 - set col 1 - set vtstate [tcl::dict::merge $vtstate $initial_state] - #todo - clear screen - } - {} { - #end of supplied line input - #lf included in data - set row $post_render_row - set col $post_render_col - if {![llength $unapplied_list]} { - if {$overflow_right ne ""} { - incr row - } - } else { - puts stderr "renderspace end of input line - has unapplied: [ansistring VIEW $unapplied] (review)" - } - set col $opt_startcolumn - } - 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 < $renderwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $renderwidth - } - } - - #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 < $renderwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $renderwidth - } - - } - } - restore_cursor { - #testfile belinda.ans uses this - - #puts stdout "[a+ blue bold]CURSOR_RESTORE[a]" - 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 [tcl::dict::get $rinfo replay_codes_overlay]$cursor_saved_attributes - #set replay_codes_overlay $cursor_saved_attributes - set cursor_saved_position [tcl::dict::create] - set cursor_saved_attributes "" - } else { - #TODO - #?restore without save? - #should move to home position and reset ansi SGR? - #puts stderr "overtype::renderspace 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 [tcl::dict::get $vtstate renderwidth]\ - -insert_mode [tcl::dict::get $vtstate insert_mode]\ - -autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\ - -expand_right [tcl::dict::get $opts -expand_right]\ - ""\ - $overflow_right\ - ] - set foldline [tcl::dict::get $sub_info result] - tcl::dict::set vtstate insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..? - tcl::dict::set vtstate 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.. - } - 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? - } - clear_and_move { - #e.g 2J - if {$post_render_row > [llength $outputlines]} { - set row [llength $outputlines] - } else { - set row $post_render_row - } - set col $post_render_col - set overflow_right "" ;#if we're clearing - any overflow due to insert_mode is irrelevant - set clearedlines [list] - foreach ln $outputlines { - lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $renderwidth]\x1b\[0m - if 0 { - - set lineparts [punk::ansi::ta::split_codes $ln] - set numcells 0 - foreach {pt _code} $lineparts { - if {$pt ne ""} { - foreach grapheme [punk::char::grapheme_split $pt] { - 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 { - incr numcells 1 - } - default { - if {$grapheme eq "\u0000"} { - incr numcells 1 - } else { - incr numcells [grapheme_width_cached $grapheme] - } - } - } - - } - } - } - #replays/resets each line - lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $numcells]\x1b\[0m - } - } - set outputlines $clearedlines - #todo - determine background/default to be in effect - DECECM ? - puts stderr "replay_codes_overlay: [ansistring VIEW $replay_codes_overlay]" - #lset outputlines 0 $replay_codes_overlay[lindex $outputlines 0] - - } - lf_start { - #raw newlines - # ---------------------- - #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 $opt_startcolumn - # ---------------------- - } - lf_mid { - - 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 $opt_startcolumn - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } else { - if 1 { - if {$overflow_right ne ""} { - if {$opt_expand_right} { - append rendered $overflow_right - set overflow_right "" - } else { - #review - we should really make renderline do the work...? - set overflow_width [punk::ansi::printing_length $overflow_right] - if {$visualwidth + $overflow_width <= $renderwidth} { - append rendered $overflow_right - set overflow_right "" - } else { - if {[tcl::dict::get $vtstate autowrap_mode]} { - set outputlines [linsert $outputlines $renderedrow $overflow_right] - set overflow_right "" - set row [expr {$renderedrow + 2}] - } else { - set overflow_right "" ;#abandon - } - - if {0 && $visualwidth < $renderwidth} { - puts stderr "visualwidth: $visualwidth < renderwidth:$renderwidth" - error "incomplete - abandon?" - set overflowparts [punk::ansi::ta::split_codes $overflow_right] - set remaining_overflow $overflowparts - set filled 0 - foreach {pt code} $overflowparts { - lpop remaining_overflow 0 - if {$pt ne ""} { - set graphemes [punk::char::grapheme_split $pt] - set add "" - set addlen $visualwidth - foreach g $graphemes { - set w [overtype::grapheme_width_cached $g] - if {$addlen + $w <= $renderwidth} { - append add $g - incr addlen $w - } else { - set filled 1 - break - } - } - append rendered $add - } - if {!$filled} { - lpop remaining_overflow 0 ;#pop code - } - } - set overflow_right [join $remaining_overflow ""] - } - } - } - } - set row $post_render_row - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } else { - #old version - known to work with various ansi graphics - e.g fruit.ans - # - but fails to limit lines to renderwidth when expand_right == 0 - append rendered $overflow_right - set overflow_right "" - set row $post_render_row - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } - } - } - lf_overflow { - #linefeed after renderwidth 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 - } - if {![tcl::dict::get $vtstate insert_mode]} { - assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right when not insert_mode - } - - 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 $opt_startcolumn - - } - 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} { - #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 $opt_startcolumn - } - } 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 < $renderwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $renderwidth - } - } - } - } - 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 $renderwidth - set r $post_render_row - if {$post_render_col > $renderwidth} { - set i $c - while {$i <= $post_render_col} { - if {$c == $renderwidth+1} { - incr r - if {$opt_appendlines} { - if {$r < [llength $outputlines]} { - lappend outputlines "" - } - } - set c $opt_startcolumn - } 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 $renderwidth - 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 $renderwidth - } 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 {[tcl::dict::get $vtstate autowrap_mode]} { - incr row - set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ?? - } else { - set col $post_render_col - #set unapplied "" ;#this seems wrong? - #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' - 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 {[tcl::dict::get $vtstate autowrap_mode]} { - if {$renderwidth < 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 $opt_startcolumn - incr row - } - } else { - set overflow_handled 1 - #handled by dropping entire overflow if any - if {$renderwidth < 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 - } - set_window_title { - set newtitle [lindex $instruction 1] - puts stderr "overtype::renderspace set_window_title [ansistring VIEW $newtitle] instruction '$instruction'" - # - } - reset_colour_palette { - puts stderr "overtype::renderspace instruction '$instruction' unimplemented" - } - default { - puts stderr "overtype::renderspace unhandled renderline instruction '$instruction'" - } - - } - - - if {!$opt_expand_right && ![tcl::dict::get $vtstate autowrap_mode]} { - #not allowed to overflow column or wrap therefore we get overflow data to truncate - if {[tcl::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 {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - if {[tcl::string::trim [punk::ansi::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::renderspace 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 "data_mode:$data_mode\n" - append debugmsg "opt_appendlines:$opt_appendlines\n" - append debugmsg "prev_row :[tcl::dict::get $renderopts -cursor_row]\n" - append debugmsg "prev_col :[tcl::dict::get $renderopts -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 - - 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 {!$opt_info} { - return $result - } else { - #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 - set inforesult [dict create\ - result $result\ - last_instruction $instruction\ - instruction_stats $instruction_stats\ - ] - if {$opt_info == 2} { - return [pdict -channel none inforesult] - } else { - return $inforesult - } - } - } - - #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 opts [tcl::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] - foreach {k v} $argsflags { - switch -- $k { - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 { - tcl::dict::set opts $k $v - } - default { - set known_opts [tcl::dict::keys $opts] - error "overtype::centre unknown option '$k'. Known options: $known_opts" - } - } - } - #set opts [tcl::dict::merge $defaults $argsflags] - # -- --- --- --- --- --- - 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 underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - set underlines [split $underblock \n] - #set renderwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] - lassign [blocksize $underblock] _w renderwidth _h renderheight - set overlines [split $overblock \n] - lassign [blocksize $overblock] _w overblock_width _h overblock_height - set under_exposed_max [expr {$renderwidth - $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 {[tcl::string::tolower [tcl::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 < $renderwidth} { - set udiff [expr {$renderwidth - $ulen}] - set undertext "$undertext[string repeat { } $udiff]" - } - set undertext $replay_codes_underlay$undertext - set overtext $replay_codes_overlay$overtext - - set overflowlength [expr {$overtext_datalen - $renderwidth}] - #review - right-to-left langs should elide on left! - extra option required - - if {$overflowlength > 0} { - #overlay line wider or equal - #review - we still expand_right for centred for now.. possibly should do something like -expand_leftright with ellipsis each end? - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right [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 {![tcl::dict::get $opts -overflow]} { - #lappend outputlines [tcl::string::range $overtext 0 [expr {$renderwidth - 1}]] - #set overtext [tcl::string::range $overtext 0 $renderwidth-1 ] - if {$opt_ellipsis} { - set show_ellipsis 1 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - #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 - } - if {$unapplied ne ""} { - append lostdata $unapplied - } - if {[tcl::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 [tcl::dict::get $rinfo result] - } - 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] - } - - #overtype::right is for a rendered ragged underblock and a rendered ragged overblock - #ie we can determine the block width for bost by examining the lines and picking the longest. - # - 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 opts [tcl::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] - tcl::dict::for {k v} $argsflags { - switch -- $k { - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -align { - tcl::dict::set opts $k $v - } - default { - set known_opts [tcl::dict::keys $opts] - error "overtype::centre unknown option '$k'. Known options: $known_opts" - } - } - } - #set opts [tcl::dict::merge $defaults $argsflags] - # -- --- --- --- --- --- - 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 underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - set underlines [split $underblock \n] - lassign [blocksize $underblock] _w renderwidth _h renderheight - 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,$renderwidth - $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 < $renderwidth} { - set udiff [expr {$renderwidth - $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 $replay_codes_underlay$undertext - set overtext $replay_codes_overlay$overtext - - set overflowlength [expr {$overtext_datalen - $renderwidth}] - 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 [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 [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - if {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set ellipsis $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(exapnd_right) 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 -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] - lappend outputlines [tcl::dict::get $rinfo result] - } - 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] - } - - proc left {args} { - overtype::block -blockalign left {*}$args - } - #overtype a (possibly ragged) underblock with a (possibly ragged) overblock - proc block {args} { - variable default_ellipsis_horizontal - # @d !todo - implement overflow, length checks etc - - 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 - lassign [lrange $args end-1 end] underblock overblock - - set opts [tcl::dict::create\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -overflow 0\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -textalign "left"\ - -textvertical "top"\ - -blockalign "left"\ - -blockalignbias left\ - -blockvertical "top"\ - ] - set argsflags [lrange $args 0 end-2] - tcl::dict::for {k v} $argsflags { - switch -- $k { - -blockalignbias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -textalign - -blockalign - -blockvertical { - tcl::dict::set opts $k $v - } - default { - error "overtype::block unknown option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - # -- --- --- --- --- --- - 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 underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - set underlines [split $underblock \n] - lassign [blocksize $underblock] _w renderwidth _h renderheight - 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,$renderwidth - $overblock_width)}] - - switch -- $opt_blockalign { - left { - set left_exposed 0 - } - right { - set left_exposed $under_exposed_max - } - centre { - 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 {[tcl::string::tolower [tcl::dict::get $opts -blockalignbias]] eq "left"} { - set left_exposed $beforehalf - } else { - #bias to the right - set left_exposed [expr {$beforehalf + 1}] - } - } - } else { - set left_exposed 0 - } - } - default { - 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 < $renderwidth} { - set udiff [expr {$renderwidth - $ulen}] - #puts xxx - append undertext [string repeat { } $udiff] - } - if {$overtext_datalen < $overblock_width} { - set odiff [expr {$overblock_width - $overtext_datalen}] - switch -- $opt_textalign { - 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 $replay_codes_underlay$undertext - set overtext $replay_codes_overlay$overtext - - set overflowlength [expr {$overtext_datalen - $renderwidth}] - 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 -expand_right $opt_overflow -startcolumn [expr {1 + $startoffset}] $undertext $overtext] - 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 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 - } - if {$unapplied ne ""} { - append lostdata $unapplied - } - if {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set rendered [overtype::block -blockalign right $rendered $opt_ellipsistext] - } - } - - #if {$opt_ellipsis} { - # set show_ellipsis 1 - # if {!$opt_ellipsiswhitespace} { - # #we don't want ellipsis if only whitespace was lost - # 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 [tcl::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 expand_right 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 -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] - #puts stderr "--> [ansistring VIEW -lf 1 -nul 1 $rinfo] <--" - 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 [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] - } - - variable optimise_ptruns 10 ;# can be set to zero to disable the ptruns branches - - # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### - # 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? - # This would probably be impractical to support for different fonts) - #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. - - #puts stderr "renderline '$args'" - variable optimise_ptruns - - if {[llength $args] < 2} { - error {usage: ?-info 0|1? ?-startcolumn ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-expand_right [1|0]? undertext overtext} - } - set under [lindex $args end-1] - set over [lindex $args end] - #lassign [lrange $args end-1 end] under over - if {[string last \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" - #} - - #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\ - -expand_right 0\ - -transparent 0\ - -startcolumn 1\ - -cursor_column 1\ - -cursor_row ""\ - -insert_mode 1\ - -crm_mode 0\ - -autowrap_mode 1\ - -reverse_mode 0\ - -info 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -cursor_restore_attributes ""\ - -cp437 0\ - -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, currsor movements to 2nd charcol, or overflow/expand_right - #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] - tcl::dict::for {k v} $argsflags { - switch -- $k { - -experimental - -cp437 - -width - -expand_right - -transparent - -startcolumn - -cursor_column - -cursor_row - - -crm_mode - -insert_mode - -autowrap_mode - -reverse_mode - - -info - -exposed1 - -exposed2 - -cursor_restore_attributes { - tcl::dict::set opts $k $v - } - default { - error "overtype::renderline unknown option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_width [tcl::dict::get $opts -width] - set opt_etabs [tcl::dict::get $opts -etabs] - set opt_expand_right [tcl::dict::get $opts -expand_right] - 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 {![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 [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 [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 opt_crm_mode [tcl::dict::get $opts -crm_mode];# CRM - show control character mode - # -- --- --- --- --- --- --- --- --- --- --- --- - set temp_cursor_saved [tcl::dict::get $opts -cursor_restore_attributes] - - set cp437_glyphs [tcl::dict::get $opts -cp437] - 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? - tcl::dict::unset cp437_map \n - } - - set opt_transparent [tcl::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 [tcl::dict::get $opts -info] - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_exposed1 [tcl::dict::get $opts -exposed1] - set opt_exposed2 [tcl::dict::get $opts -exposed2] - # -- --- --- --- --- --- --- --- --- --- --- --- - - if {$opt_row_context eq ""} { - set cursor_row 1 - } else { - set cursor_row $opt_row_context - } - - set insert_mode $opt_insert_mode ;#default 1 - set autowrap_mode $opt_autowrap_mode ;#default 1 - set crm_mode $opt_crm_mode ;#default 0 (Show Control Character mode) - set reverse_mode $opt_reverse_mode - - #----- - # - 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 - } - - 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 ""} { - 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] - } - set understacks [list] - set understacks_gx [list] - set pm_list [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 expand_right 0 truncation - set remainder [list] ;#for returnextra - foreach {pt code} $undermap { - #pt = plain text - #append pt_underchars $pt - if {$pt ne ""} { - if {$cp437_glyphs} { - set pt [tcl::string::map $cp437_map $pt] - } - set is_ptrun 0 - if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { - set p1 [tcl::string::index $pt 0] - set hex [format %x [scan $p1 %c]] ;#punk::char::char_hex - set re [tcl::string::cat {^[} \\U$hex {]+$}] - set is_ptrun [regexp $re $pt] - } - if {$is_ptrun} { - #switch -- $p1 { - # " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - - # 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 {$p1 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 $p1] ;# when zero??? - # } - # } - #} - set width [grapheme_width_cached $p1] ;# when zero??? - set ptlen [string length $pt] - if {$width <= 1} { - #review - 0 and 1? - incr i_u $ptlen - lappend understacks {*}[lrepeat $ptlen $u_codestack] - lappend understacks_gx {*}[lrepeat $ptlen $u_gx_stack] - lappend undercols {*}[lrepeat $ptlen $p1] - } else { - incr i_u $ptlen ;#2nd col empty str - so same as above - set 2ptlen [expr {$ptlen * 2}] - lappend understacks {*}[lrepeat $2ptlen $u_codestack] - lappend understacks_gx {*}[lrepeat $2ptlen $u_gx_stack] - set l [concat {*}[lrepeat $ptlen [list $p1 ""]] - lappend undercols {*}$l - unset l - } - - } else { - foreach grapheme [punk::char::grapheme_split $pt] { - #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 - - 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 { - #zero width still acts as 1 below??? review what should happen - 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] ;#can only use with graphemes that have a single replacement char.. - 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 - #keep any remaining PMs in place - if {$code ne ""} { - set c1c2 [tcl::string::range $code 0 1] - - set leadernorm [tcl::string::range [tcl::string::map [list\ - \x1b\[ 7CSI\ - \x9b 8CSI\ - \x1b\( 7GFX\ - \x1b^ 7PMX\ - \x1bX 7SOS\ - ] $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 {[tcl::string::index $c1c2 0] eq "\x1b"} { - set maybemouse [tcl::string::index $code 2] - } - - 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]} { - 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 -- [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 - } - B { - set u_gx_stack [list] - } - } - } - 7PMX - 7SOS { - #we can have PMs or SOS (start of string) in the underlay - though mostly the PMs should have been processed.. - #attach the PM/SOS (entire ANSI sequence) to the previous grapheme! - #It should not affect the size - but terminal display may get thrown out if terminal doesn't support them. - - #note that there may in theory already be ANSI stored - we don't assume it was a pure grapheme string - set graphemeplus [lindex $undercols end] - if {$graphemeplus ne "\0"} { - append graphemeplus $code - } else { - set graphemeplus $code - } - lset undercols end $graphemeplus - #The grapheme_width_cached function will be called on this later - and doesn't account for ansi. - #we need to manually cache the item with it's proper width - variable grapheme_widths - #stripped and plus version keys pointing to same length - dict set grapheme_widths $graphemeplus [grapheme_width_cached [::punk::ansi::ansistrip $graphemeplus]] - - } - 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..? - } - - #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} { - #set undercols [list {*}$undercols {*}[lrepeat $diff "\u0000"]] ;#2024 - much slower - lappend undercols {*}[lrepeat $diff "\u0000"] - lappend understacks {*}[lrepeat $diff $cs] - lappend understacks_gx {*}[lrepeat $diff $gs] - } - } - } - - if {$opt_width ne "\uFFEF"} { - set renderwidth $opt_width - } else { - set renderwidth [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 containing the right number of columns. - #this will be processed as transparent - and handle doublewidth underlay characters appropriately - set startpadding [string repeat " " [expr {$opt_colstart -1}]] - #overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency - if {$startpadding ne "" || $overdata ne ""} { - if {[punk::ansi::ta::detect $overdata]} { - set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata] - } else { - #single plaintext part - set overmap [list $startpadding$overdata] - } - } else { - set overmap [list] - } - #### - - - #todo - detect plain ascii no-ansi input line (aside from leading ansi reset) - #will that allow some optimisations? - - #todo - detect repeated transparent char in overlay - #regexp {^(.)\1+$} ;#backtracking regexp - relatively slow. - # - try set c [string index $data 0]; regexp [string map [list %c% $c] {^[%c%]+$}] $data - #we should be able to optimize to pass through the underlay?? - - #??? - 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 {$pt ne ""} { - #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 [tcl::string::map $cp437_map $pt] - } - append pt_overchars $pt - #will get empty pt between adjacent codes - if {!$crm_mode} { - - set is_ptrun 0 - if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { - set p1 [tcl::string::index $pt 0] - set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+$}] - set is_ptrun [regexp $re $pt] - - #leading only? we would have to check for graphemes at the trailing boundary? - #set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+}] - #set is_ptrun [regexp -indices $re $pt runrange] - #if {$is_ptrun && 1} { - #} - } - if {$is_ptrun} { - #review - in theory a run over a certain length won't be part of some grapheme combo (graphemes can be long e.g 44?, but not as runs(?)) - #could be edge cases for runs at line end? (should be ok as we include trailing \n in our data) - set len [string length $pt] - set g_element [list g $p1] - - #lappend overstacks {*}[lrepeat $len $o_codestack] - #lappend overstacks_gx {*}[lrepeat $len $o_gxstack] - #incr i_o $len - #lappend overlay_grapheme_control_list {*}[lrepeat $len [list g $p1]] - #lappend overlay_grapheme_control_stacks {*}[lrepeat $len $o_codestack] - - set pi 0 - incr i_o $len - while {$pi < $len} { - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - lappend overlay_grapheme_control_list $g_element - lappend overlay_grapheme_control_stacks $o_codestack - incr pi - } - } else { - 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 - } - } - } else { - set tsbegin [clock micros] - foreach grapheme_original [punk::char::grapheme_split $pt] { - set pt_crm [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $grapheme_original] - #puts stderr "ptlen [string length $pt] graphemelen[string length $grapheme_original] pt_crmlen[string length $pt_crm] $pt_crm" - foreach grapheme [punk::char::grapheme_split $pt_crm] { - if {$grapheme eq "\n"} { - lappend overlay_grapheme_control_stacks $o_codestack - lappend overlay_grapheme_control_list [list crmcontrol "\x1b\[00001E"] - } else { - 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 - } - } - } - set elapsed [expr {[clock micros] - $tsbegin}] - puts stderr "ptlen [string length $pt] elapsedus:$elapsed" - } - } - - #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 ""} { - #we need to immediately set crm_mode here if \x1b\[3h received - if {$code eq "\x1b\[3h"} { - set crm_mode 1 - } elseif {$code eq "\x1b\[3l"} { - set crm_mode 0 - } - #else crm_mode could be set either way from options - if {$crm_mode && $code ne "\x1b\[00001E"} { - #treat the code as type 'g' like above - only allow through codes to reset mode REVIEW for now just \x1b\[3l ? - #we need to somehow convert further \n in the graphical rep to an instruction for newline that will bypass further crm_mode processing or we would loop. - set code_as_pt [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $code] - #split using standard split for first foreach loop - grapheme based split when processing 2nd foreach loop - set chars [split $code_as_pt ""] - set codeparts [list] ;#list of 2-el lists each element {crmcontrol } or {g } - foreach c $chars { - if {$c eq "\n"} { - #use CNL (cursor next line) \x1b\[00001E ;#leading zeroes ok for this processor - used as debugging aid to distinguish - lappend codeparts [list crmcontrol "\x1b\[00001E"] - } else { - if {[llength $codeparts] > 0 && [lindex $codeparts end 0] eq "g"} { - set existing [lindex $codeparts end 1] - lset codeparts end [list g [string cat $existing $c]] - } else { - lappend codeparts [list g $c] - } - } - } - - set partidx 0 - foreach record $codeparts { - lassign $record rtype rval - switch -exact -- $rtype { - g { - append pt_overchars $rval - foreach grapheme [punk::char::grapheme_split $rval] { - 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 - } - } - crmcontrol { - #leave o_codestack - lappend overlay_grapheme_control_stacks $o_codestack - lappend overlay_grapheme_control_list [list crmcontrol $rval] - } - } - } - } else { - 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 { - #review - 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 {[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 "" - #} - # -- --- --- --- --- --- --- --- - - - #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_expand_right} { - #expand_right 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. - #we currently only support horizontal expansion to the right (review regarding RTL text!) - set overflow_idx -1 - } else { - #expand_right 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 -expand_right 1 "" data - - #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" - 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 - #crm_mode affects both graphic and control - if {0 && $crm_mode} { - set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $ch] - set chars [string map [list \n "\x1b\[00001E"] $chars] - if {[llength [split $chars ""]] > 1} { - priv::render_unapplied $overlay_grapheme_control_list $gci - #prefix the unapplied controls with the string version of this control - set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] - set unapplied [join $unapplied_list ""] - #incr idx_over - break - } else { - set ch $chars - } - } - 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 <= $renderwidth-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 [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 { - "" { - 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 expand_right = 1 - 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" - if {$insert_mode == 0} { - incr cursor_row - if {$idx == -1 || $overflow_idx > $idx} { - #don't set overflow_idx higher if it's already set lower and we're adding graphemes to overflow - set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 - } - set instruction lf_mid - priv::render_unapplied $overlay_grapheme_control_list $gci - break - } else { - incr cursor_row - #don't adjust the overflow_idx - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction lf_mid - break ;# could have overdata following the \n - don't keep processing - } - } - - } - "" { - #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 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} { - #REVIEW - set next_gc [lindex $overlay_grapheme_control_list $gci+1] ;#next grapheme or control - lassign $next_gc next_type next_item - if {$autowrap_mode || $next_type ne "g"} { - 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 { - #no point throwing back to caller for each grapheme that is overflowing - #without this branch - renderline would be called with overtext reducing only by one grapheme per call - #processing a potentially long overtext each time (ie - very slow) - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #JMN4 - - } - } - } else { - #review. - #overflow_idx = -1 - #This corresponds to expand_right 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 " " - #tcl::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] - #JMN - 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 [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 - 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 [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 - } - } - } 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} { - 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 - } - } - } - } ;# end switch - - - } - other - crmcontrol { - if {$crm_mode && $type ne "crmcontrol" && $item ne "\x1b\[00001E"} { - if {$item eq "\x1b\[3l"} { - set crm_mode 0 - } else { - #When our initial overlay split was done - we weren't in crm_mode - so there are codes that weren't mapped to unicode control character representations - #set within_undercols [expr {$idx <= $renderwidth-1}] - #set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $item] - set chars [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $item] - priv::render_unapplied $overlay_grapheme_control_list $gci - #prefix the unapplied controls with the string version of this control - set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] - set unapplied [join $unapplied_list ""] - - break - } - } - - #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 possibly 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' - - - #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? - - 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)} - #tcl 8.7 - faster to use inline list than to store it in a local var outside of loop. - #(somewhat surprising) - set leadernorm [tcl::string::range [tcl::string::map [list\ - \x1b\[< 1006\ - \x1b\[ 7CSI\ - \x1bY 7MAP\ - \x1bP 7DCS\ - \x90 8DCS\ - \x9b 8CSI\ - \x1b\] 7OSC\ - \x9d 8OSC\ - \x1b 7ESC\ - ] $c1c2c3] 0 3] ;#leadernorm is 1st 1,2 or 3 chars mapped to 4char normalised indicator - or is original first chars (1,2 or 3 len) - - #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 [tcl::string::cat $leadernorm [tcl::string::range $code 3 end]] - } - 7CSI - 7OSC { - #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] - set codenorm $leadernorm[tcl::string::range $code 2 end] - } - 7DCS { - #ESC P - #Device Control String https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h4-Controls-beginning-with-ESC:ESC-F.C74 - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] - } - 8DCS { - #8-bit Device Control String - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] - } - 7MAP { - #map to another type of code to share implementation branch - set codenorm $leadernorm[tcl::string::range $code 1 end] - } - 7ESC { - #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] - set codenorm $leadernorm[tcl::string::range $code 1 end] - } - 8CSI - 8OSC { - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] - } - default { - puts stderr "Sequence detected as ANSI, but not handled in leadernorm switch. code: [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - #we haven't made a mapping for this - #could in theory be 1,2 or 3 in len - #although we shouldn't be getting here if the regexp for ansi codes is kept in sync with our switch branches - set codenorm $code - } - } - - switch -- $leadernorm { - 7MAP { - switch -- [lindex $codenorm 4] { - Y { - #vt52 movement. we expect 2 chars representing position (limited range) - set params [tcl::string::range $codenorm 5 end] - if {[tcl::string::length $params] != 2} { - #shouldn't really get here or need this branch if ansi splitting was done correctly - puts stderr "overtype::renderline ESC Y recognised as vt52 move, but incorrect parameters length ([string length $params] vs expected 2) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]" - } - set line [tcl::string::index $params 5] - set column [tcl::string::index $params 1] - set r [expr {[scan $line %c] -31}] - set c [expr {[scan $column %c] -31}] - - #MAP to: - #CSI n;m H - CUP - Cursor Position - set leadernorm 7CSI - set codenorm "$leadernorm${r}\;${c}H" - } - } - } - } - - #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 -- [tcl::string::index $codenorm end] { - M { - puts stderr "mousedown $codenorm" - } - m { - puts stderr "mouseup $codenorm" - } - } - - } - {7CSI} - {8CSI} { - set param [tcl::string::range $codenorm 4 end-1] - #puts stdout "--> CSI [tcl::string::index $leadernorm 0] bit param:$param" - set code_end [tcl::string::index $codenorm end] ;#used for e.g h|l set/unset mode - - switch -exact -- $code_end { - A { - #Row move - up - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #todo - lassign [split $param {;}] num modifierkey - if {$modifierkey ne ""} { - puts stderr "modifierkey:$modifierkey" - } - - 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 { - #CUD - Cursor Down - #Row move - down - lassign [split $param {;}] num modifierkey - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #move down - if {$modifierkey ne ""} { - puts stderr "modifierkey:$modifierkey" - } - 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 - } - C { - #CUF - Cursor Forward - #Col move - #puts stdout "->forward" - #todo - consider right-to-left cursor mode (e.g Hebrew).. some day. - #cursor forward - #right-arrow/move forward - lassign [split $param {;}] num modifierkey - if {$modifierkey ne ""} { - puts stderr "modifierkey:$modifierkey" - } - 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 {$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_right and 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 { - #review - dead branch - if {!$expand_right || ($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 {[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] - #} - 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 [tcl::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}] - } - } - } - } - } - D { - #Col move - #puts stdout "<-back" - #cursor back - #left-arrow/move-back when ltr mode - lassign [split $param {;}] num modifierkey - if {$modifierkey ne ""} { - puts stderr "modifierkey:$modifierkey" - } - 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 - } - } - } - E { - #CNL - Cursor Next Line - if {$param eq ""} { - set downmove 1 - } else { - set downmove [expr {$param}] - } - puts stderr "renderline CNL down-by-$downmove" - set cursor_column 1 - set cursor_row [expr {$cursor_row + $downmove}] - set idx [expr {$cursor_column -1}] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move - break - - } - F { - #CPL - Cursor Previous Line - if {$param eq ""} { - set upmove 1 - } else { - set upmove [expr {$param}] - } - puts stderr "renderline CPL up-by-$upmove" - set cursor_column 1 - set cursor_row [expr {$cursor_row -$upmove}] - if {$cursor_row < 1} { - set cursor_row 1 - } - set idx [expr {$cursor_column - 1}] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move - break - - } - G { - #CHA - Cursor Horizontal Absolute (move to absolute column no) - if {$param eq ""} { - set targetcol 1 - } else { - set targetcol $param - if {![string is integer -strict $targetcol]} { - puts stderr "renderline CHA (Cursor Horizontal Absolute) error. Unrecognised parameter '$param'" - } - set targetcol [expr {$param}] - set max [llength $outcols] - if {$overflow_idx == -1} { - incr max - } - if {$targetcol > $max} { - puts stderr "renderline CHA (Cursor Horizontal Absolute) error. Param '$param' > max: $max" - set targetcol $max - } - } - #adjust to colstart - as column 1 is within overlay - #??? REVIEW - set idx [expr {($targetcol -1) + $opt_colstart -1}] - - - set cursor_column $targetcol - #puts stderr "renderline absolute col move ESC G (TEST)" - } - H - f { - #CSI n;m H - CUP - Cursor Position - - #CSI n;m f - HVP - Horizontal Vertical Position REVIEW - same as CUP with differences (what?) in some terminal modes - # - 'counts as effector format function (like CR or LF) rather than an editor function (like CUD or CNL)' - # - REVIEW - #see Annex A at: https://www.ecma-international.org/wp-content/uploads/ECMA-48_5th_edition_june_1991.pdf - - #test e.g ansicat face_2.ans - #$re_both_move - lassign [split $param {;}] paramrow paramcol - #missing defaults to 1 - #CSI ;5H = CSI 1;5H -> row 1 col 5 - #CSI 17;H = CSI 17H = CSI 17;1H -> row 17 col 1 - - if {$paramcol eq ""} {set paramcol 1} - if {$paramrow eq ""} {set paramrow 1} - if {![string is integer -strict $paramcol] || ![string is integer -strict $paramrow]} { - puts stderr "renderline CUP (CSI H) unrecognised param $param" - #ignore? - } else { - set max [llength $outcols] - if {$overflow_idx == -1} { - incr max - } - if {$paramcol > $max} { - set target_column $max - } else { - set target_column [expr {$paramcol}] - } - - - if {$paramrow < 1} { - puts stderr "renderline CUP (CSI H) bad row target 0. Assuming 1" - set target_row 1 - } else { - set target_row [expr {$paramrow}] - } - if {$target_row == $cursor_row} { - #col move only - no need for break and move - #puts stderr "renderline CUP col move only to col $target_column param:$param" - set cursor_column $target_column - set idx [expr {$cursor_column -1}] - } else { - set cursor_row $target_row - set cursor_column $target_column - set idx [expr {$cursor_column -1}] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move - break - } - } - } - J { - set modegroup [tcl::string::index $codenorm 4] ;#e.g ? - switch -exact -- $modegroup { - ? { - #CSI ? Pn J - selective erase - puts stderr "overtype::renderline ED - SELECTIVE ERASE IN DISPLAY (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - default { - puts stderr "overtype::renderline ED - ERASE IN DISPLAY (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - if {$param eq ""} {set param 0} - switch -exact -- $param { - 0 { - #clear from cursor to end of screen - } - 1 { - #clear from cursor to beginning of screen - } - 2 { - #clear entire screen - #ansi.sys - move cursor to upper left REVIEW - set cursor_row 1 - set cursor_column 1 - set idx [expr {$cursor_column -1}] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr idx_over - if {[llength $outcols]} { - priv::render_erasechar 0 [llength $outcols] - } - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction clear_and_move - break - } - 3 { - #clear entire screen. presumably cursor doesn't move - otherwise it would be same as 2J ? - - } - default { - } - } - - } - } - } - K { - #see DECECM regarding background colour - set modegroup [tcl::string::index $codenorm 4] ;#e.g ? - switch -exact -- $modegroup { - ? { - puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - set param [string range $param 1 end] ;#chop qmark - if {$param eq ""} {set param 0} - switch -exact -- $param { - 0 { - #clear from cursor to end of line - depending on DECSCA - } - 1 { - #clear from cursor to beginning of line - depending on DECSCA - - } - 2 { - #clear entire line - depending on DECSCA - } - default { - puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - - } - default { - puts stderr "overtype::renderline EL - ERASE IN LINE (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - if {$param eq ""} {set param 0} - switch -exact -- $param { - 0 { - #clear from cursor to end of line - } - 1 { - #clear from cursor to beginning of line - - } - 2 { - #clear entire line - } - default { - puts stderr "overtype::renderline EL - ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - } - } - } - L { - puts stderr "overtype::renderline IL - Insert Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - M { - #CSI Pn M - DL - Delete Line - puts stderr "overtype::renderline DL - Delete Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - - } - T { - #CSI Pn T - SD Pan Up (empty lines introduced at top) - #CSI Pn+T - kitty extension (lines at top come from scrollback buffer) - #Pn new lines appear at top of the display, Pn old lines disappear at the bottom of the display - if {$param eq "" || $param eq "0"} {set param 1} - if {[string index $param end] eq "+"} { - puts stderr "overtype::renderline CSI Pn + T - kitty Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } else { - puts stderr "overtype::renderline CSI Pn T - SD Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - X { - puts stderr "overtype::renderline X ECH ERASE CHARACTER - $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. - } - q { - set code_secondlast [tcl::string::index $codenorm end-1] - switch -exact -- $code_secondlast { - {"} { - #DECSCA - Select Character Protection Attribute - #(for use with selective erase: DECSED and DECSEL) - set param [tcl::string::range $codenorm 4 end-2] - if {$param eq ""} {set param 0} - #TODO - store like SGR in stacks - replays? - switch -exact -- $param { - 0 - 2 { - #canerase - puts stderr "overtype::renderline - DECSCA canerase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - 1 { - #cannoterase - puts stderr "overtype::renderline - DECSCA cannoterase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - default { - puts stderr "overtype::renderline DECSCA param '$param' not understood [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - - } - default { - puts stderr "overtype::renderline - CSI ... q not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - - } - 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 { - #code conflict between ansi emulation and DECSLRM - REVIEW - #ANSISYSSC (when no parameters) - like other terminals - essentially treat same as DECSC - # todo - when parameters - support DECSLRM instead - - if {$param ne ""} { - #DECSLRM - should only be recognised if DECLRMM is set (vertical split screen mode) - lassign [split $param {;} margin_left margin_right - puts stderr "overtype DECSLRM not yet supported - got [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - if {$margin_left eq ""} { - set margin_left 1 - } - set columns_per_page 80 ;#todo - set to 'page width (DECSCPP set columns per page)' - could be 132 or?? - if {$margin_right eq ""} { - set margin_right $columns_per_page - } - puts stderr "DECSLRM margin left: $margin_left margin right: $margin_right" - if {![string is integer -strict $margin_left] || $margin_left < 0} { - puts stderr "DECSLRM invalid margin_left" - } - if {![string is integer -strict $margin_right] || $margin_right < 0} { - puts stderr "DECSLRM invalid margin_right" - } - set scrolling_region_size [expr {$margin_right - $margin_left}] - if {$scrolling_region_size < 2 || $scrolling_region_size > $columns_per_page} { - puts stderr "DECSLRM region size '$scrolling_regsion_size' must be between 1 and $columns_per_page" - } - #todo - - - } else { - #DECSC - #//notes on expected behaviour: - #DECSC - saves following items in terminal's memory - #cursor position - #character attributes set by the SGR command - #character sets (G0,G1,G2 or G3) currently in GL and GR - #Wrap flag (autowrap or no autowrap) - #State of origin mode (DECOM) - #selective erase attribute - #any single shift 2 (SS2) or single shift 3(SSD) functions sent - - #$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 { - #ANSISYSRC save cursor (when no parameters) (DECSC) - - #$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 - } - "{" { - - puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" - } - "}" { - set code_secondlast [tcl::string::index $codenorm end-1] - switch -exact -- $code_secondlast { - ' { - puts stderr "renderline warning - DECIC - Insert Column - CSI...' - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" - } - default { - puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" - } - } - } - ~ { - set code_secondlast [tcl::string::index $codenorm end-1] ;#used for e.g CSI x '~ - switch -exact -- $code_secondlast { - ' { - #DECDC - editing sequence - Delete Column - puts stderr "renderline warning - DECDC - unimplemented" - } - default { - #$re_vt_sequence - 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 { - #set mode unset mode - #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 - set modegroup [tcl::string::index $codenorm 4] ;#e.g ? = - switch -exact -- $modegroup { - ? { - set smparams [tcl::string::range $codenorm 5 end-1] ;#params between ? and h|l - #one or more modes can be set - set smparam_list [split $smparams {;}] - foreach num $smparam_list { - switch -- $num { - "" { - #ignore empties e.g extra/trailing semicolon in params - } - 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 - - if {$code_end eq "h"} { - #set (enable) - set reverse_mode 1 - } else { - #reset (disable) - set reverse_mode 0 - } - - } - 7 { - #DECAWM autowrap - if {$code_end 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 usually - but sanity check with warning for now. - if {$idx >= $overflow_idx} { - puts stderr "renderline warning - idx '$idx' >= overflow_idx '$overflow_idx' - unexpected" - } - } else { - #reset (disable) - set autowrap_mode 0 - #REVIEW! - set overflow_idx -1 - } - } - 25 { - if {$code_end eq "h"} { - #visible cursor - - } else { - #invisible cursor - - } - } - 117 { - #DECECM - Erase Color Mode - #https://invisible-island.net/ncurses/ncurses.faq.html - #The Erase color selection controls the background color used when text is erased or new - #text is scrolled on to the screen. Screen background causes newly erased areas or - #scrolled text to be written using color index zero, the screen background. This is VT - #and DECterm compatible. Text background causes erased areas or scrolled text to be - #written using the current text background color. This is PC console compatible and is - #the factory default. - - #see also: https://unix.stackexchange.com/questions/251726/clear-to-end-of-line-uses-the-wrong-background-color-in-screen - } - } - } - } - = { - set num [tcl::string::range $codenorm 5 end-1] ;#param between = and h|l - puts stderr "overtype::renderline CSI=...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - default { - #e.g CSI 4 h - set num [tcl::string::range $codenorm 4 end-1] ;#param before h|l - switch -exact -- $num { - 3 { - puts stderr "CRM MODE $code_end" - #CRM - Show control character mode - # 'No control functions are executed except LF,FF and VT which are represented in the CRM FONT before a CRLF(new line) is executed' - # - #use ansistring VIEW -nul 1 -lf 2 -ff 2 -vt 2 - #https://vt100.net/docs/vt510-rm/CRM.html - #NOTE - vt100 CRM always does auto-wrap at right margin. - #disabling auto-wrap in set-up or by sequence is disabled. - #We should default to turning off auto-wrap when crm_mode enabled.. but - #displaying truncated (on rhs) crm can still be very useful - and we have optimisation in overflow to avoid excess renderline calls (per grapheme) - #we therefore could reasonably put in an exception to allow auto_wrap to be disabled after crm_mode is engaged, - #although this would be potentially an annoying difference to some.. REVIEW - if {$code_end eq "h"} { - set crm_mode 1 - 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 - } - } else { - set crm_mode 0 - } - } - 4 { - #IRM - Insert/Replace Mode - if {$code_end eq "h"} { - #CSI 4 h - set insert_mode 1 - } else { - #CSI 4 l - #replace mode - set insert_mode 0 - } - } - default { - puts stderr "overtype::renderline CSI...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - } - } - } - } - | { - switch -- [tcl::string::index $codenorm end-1] { - {$} { - #CSI ... $ | DECSCPP set columns per page- (recommended in vt510 docs as preferable to DECCOLM) - #real terminals generally only supported 80/132 - #some other virtuals support any where from 2 to 65,536? - #we will allow arbitrary widths >= 2 .. to some as yet undetermined limit. - #CSI $ | - #empty or 0 param is 80 for compatibility - other numbers > 2 accepted - set page_width -1 ;#flag as unset - if {$param eq ""} { - set page_width 80 - } elseif {[string is integer -strict $param] && $param >=2 0} { - set page_width [expr {$param}] ;#we should allow leading zeros in the number - but lets normalize using expr - } else { - puts stderr "overtype::renderline unacceptable DECSPP value '$param'" - } - - if {$page_width > 2} { - puts stderr "overtype::renderline DECSCPP - not implemented - but selected width '$page_width' looks ok" - #if cursor already beyond new page_width - will move to right colum - otherwise no cursor movement - - } - - } - default { - puts stderr "overtype::renderline unrecognised CSI code ending in pipe (|) [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 {\x1b(D|M|E)$} - #also vt52 Y.. - #also PM \x1b^...(ST) - switch -- [tcl::string::index $codenorm 4] { - c { - #RIS - reset terminal to initial state - where 'terminal' in this case is the renderspace - not the underlying terminal! - puts stderr "renderline reset" - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction reset - break - } - 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 "renderline ESC D not fully implemented" - incr cursor_row - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction 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 "overtype::renderline ESC E unimplemented" - - } - H { - #\x88 - #Tab Set - puts stderr "overtype::renderline ESC H tab set unimplemented" - } - 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 "overtype::renderline 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 - } - N { - #\x8e - affects next character only - puts stderr "overtype::renderline single shift select G2 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - O { - #\x8f - affects next character only - puts stderr "overtype::renderline single shift select G3 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - P { - #\x90 - #DCS - shouldn't get here - handled in 7DCS branch - #similarly \] OSC (\x9d) and \\ (\x9c) ST - } - V { - #\x96 - - } - W { - #\x97 - } - X { - #\x98 - #SOS - if {[string index $code end] eq "\007"} { - set sos_content [string range $code 2 end-1] ;#ST is \007 - } else { - set sos_content [string range $code 2 end-2] ;#ST is \x1b\\ - } - #return in some useful form to the caller - #TODO! - lappend sos_list [list string $sos_content row $cursor_row column $cursor_column] - puts stderr "overtype::renderline ESCX SOS UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - ^ { - #puts stderr "renderline PM" - #Privacy Message. - if {[string index $code end] eq "\007"} { - set pm_content [string range $code 2 end-1] ;#ST is \007 - } else { - set pm_content [string range $code 2 end-2] ;#ST is \x1b\\ - } - #We don't want to render it - but we need to make it available to the application - #see the textblock library in punk, for the exception we make here for single backspace. - #It is unlikely to be encountered as a useful PM - so we hack to pass it through as a fix - #for spacing issues on old terminals which miscalculate the single-width 'Symbols for Legacy Computing' - if {$pm_content eq "\b"} { - #puts stderr "renderline PM sole backspace special handling for \U1FB00 - \U1FBFF" - #esc^\b\007 or esc^\besc\\ - #HACKY pass-through - targeting terminals that both mis-space legacy symbols *and* don't support PMs - #The result is repair of the extra space. If the terminal is a modern one and does support PM - the \b should be hidden anyway. - #If the terminal has the space problem AND does support PMs - then this just won't fix it. - #The fix relies on the symbol-supplier to cooperate by appending esc^\b\esc\\ to the problematic symbols. - - #priv::render_addchar $idx $code [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - #idx has been incremented after last grapheme added - priv::render_append_to_char [expr {$idx -1}] $code - } - #lappend to a dict element in the result for application-specific processing - lappend pm_list $pm_content - } - _ { - #APC Application Program Command - #just warn for now.. - puts stderr "overtype::renderline ESC_ APC command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - default { - puts stderr "overtype::renderline ESC code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]" - } - } - - } - 7DCS - 8DCS { - puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - #ST (string terminator) \x9c or \x1b\\ - if {[tcl::string::index $codenorm end] eq "\x9c"} { - set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is 8-bit 0x9c - } else { - set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\ - } - - } - 7OSC - 8OSC { - # OSCs are terminated with ST of either \007 or \x1b\\ - we allow either whether code was 7 or 8 bit - if {[tcl::string::index $codenorm end] eq "\007"} { - set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is \007 - } else { - set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\ - } - set first_colon [tcl::string::first {;} $code_content] - if {$first_colon == -1} { - #there probably should always be a colon - but we'll try to make sense of it without - set osc_code $code_content ;#e.g \x1b\]104\007 vs \x1b\]104\;\007 - } else { - set osc_code [tcl::string::range $code_content 0 $first_colon-1] - } - switch -exact -- $osc_code { - 2 { - set newtitle [tcl::string::range $code_content 2 end] - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction [list set_window_title $newtitle] - break - } - 4 { - #OSC 4 - set colour palette - #can take multiple params - #e.g \x1b\]4\;1\;red\;2\;green\x1b\\ - set params [tcl::string::range $code_content 2 end] ;#strip 4 and first semicolon - set cmap [dict create] - foreach {cnum spec} [split $params {;}] { - if {$cnum >= 0 and $cnum <= 255} { - #todo - parse spec from names like 'red' to RGB - #todo - accept rgb:ab/cd/ef as well as rgb:/a/b/c (as alias for aa/bb/cc) - #also - what about rgb:abcd/defg/hijk and 12-bit abc/def/ghi ? - dict set cmap $cnum $spec - } else { - #todo - log - puts stderr "overtype::renderline OSC 4 set colour palette - bad color number: $cnum must be from 0 to 255. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - - puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - - - } - 10 - 11 - 12 - 13 - 14 - 15 - 16 - 17 { - #OSC 10 through 17 - so called 'dynamic colours' - #can take multiple params - each successive parameter changes the next colour in the list - #- e.g if code started at 11 - next param is for 12. 17 takes only one param because there are no more - #10 change text foreground colour - #11 change text background colour - #12 change text cursor colour - #13 change mouse foreground colour - #14 change mouse background colour - #15 change tektronix foreground colour - #16 change tektronix background colour - #17 change highlight colour - set params [tcl::string::range $code_content 2 end] - - puts stderr "overtype::renderline OSC $osc_code set dynamic colours unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - - - } - 18 { - #why is this not considered one of the dynamic colours above? - #https://www.xfree86.org/current/ctlseqs.html - #tektronix cursor color - puts stderr "overtype::renderline OSC 18 - set tektronix cursor color unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - 99 { - #kitty desktop notifications - #https://sw.kovidgoyal.net/kitty/desktop-notifications/ - # 99 ; metadata ; payload - puts stderr "overtype::renderline OSC 99 kitty desktop notification unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - 104 { - #reset colour palette - #we want to do it for the current rendering context only (vvt) - not just pass through to underlying vt - puts stderr "overtype::renderline OSC 104 reset colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction [list reset_colour_palette] - break - } - 1337 { - #iterm2 graphics and file transfer - puts stderr "overtype::renderline OSC 1337 iterm2 graphics/file_transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]" - } - 5113 { - puts stderr "overtype::renderline OSC 5113 kitty file transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]" - } - default { - puts stderr "overtype::renderline OSC - UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - - } - default { - } - } - - - } - 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_expand_right == 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 - } - set trailing_nulls 0 - foreach ch [lreverse $outcols] { - if {$ch eq "\u0000"} { - incr trailing_nulls - } else { - break - } - } - if {$trailing_nulls} { - set first_tail_null_posn [expr {[llength $outcols] - $trailing_nulls}] - } else { - set first_tail_null_posn -1 - } - - #puts stderr "first_tail_null_posn: $first_tail_null_posn" - #puts stderr "colview: [ansistring VIEW $outcols]" - - foreach ch $outcols { - #puts "---- [ansistring VIEW $ch]" - - set gxleader "" - if {$i < [llength $understacks_gx]} { - #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"]} { - 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 [tcl::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 {$ch eq "\u0000"} { - if {$cp437_glyphs} { - #map all nulls including at tail to space - append outstring " " - } else { - if {$trailing_nulls && $i < $first_tail_null_posn} { - append outstring " " ;#map inner nulls to space - } else { - append outstring \u0000 - } - } - } else { - append outstring $ch - } - } - incr i - } - #flower.ans good test for null handling - reverse line building - #review - presence of overflow_right doesn't indicate line's trailing nulls should remain. - #The cells could have been erased? - #if {!$cp437_glyphs} { - # #if {![ansistring length $overflow_right]} { - # # set outstring [tcl::string::trimright $outstring "\u0000"] - # #} - # set outstring [tcl::string::trimright $outstring "\u0000"] - # set outstring [tcl::string::map {\u0000 " "} $outstring] - #} - - - #REVIEW - #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 [tcl::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 [tcl::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\ - crm_mode $crm_mode\ - reverse_mode $reverse_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\ - expand_right $opt_expand_right\ - replay_codes $replay_codes\ - replay_codes_underlay $replay_codes_underlay\ - replay_codes_overlay $replay_codes_overlay\ - pm_list $pm_list\ - ] - if {$opt_returnextra == 1} { - #puts stderr "renderline: $result" - 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. - } - } - 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 { - #puts stderr "renderline returning: result $outstring instruction $instruction unapplied $unapplied overflow_right $overflow_right" - return $outstring - } - #return [join $out ""] - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace overtype ---}] -} - -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} - } - 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 [tcl::dict::create\ - -transparent 1\ - -exposed 1 " "\ - -exposed 2 " "\ - ] - 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. -# -tcl::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 primarily for single grapheme - but will work for multiple -#WARNING: query CAN contain ansi or newlines - but if cache was not already set manually,the answer will be incorrect! -#We deliberately allow this for PM/SOS attached within a column -#(a cache of ansifreestring_width calls - as these are quite regex heavy) -proc overtype::grapheme_width_cached {ch} { - variable grapheme_widths - if {[tcl::dict::exists $grapheme_widths $ch]} { - return [tcl::dict::get $grapheme_widths $ch] - } - set width [punk::char::ansifreestring_width $ch] - tcl::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 [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 {[tcl::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] - } - #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::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 - 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 [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 -} - -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 {[tcl::dict::exists $cache_is_sgr $code]} { - return [tcl::dict::get $cache_is_sgr $code] - } - set answer [punk::ansi::codetype::is_sgr $code] - tcl::dict::set cache_is_sgr $code $answer - return $answer - } - # better named render_to_unapplied? - 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] - } elseif {$i == 0 || $i == $nxt} { - #nothing to do - } else { - puts stderr "render_delchar - attempt to delchar at index $i >= number of outcols $nxt - shouldn't happen" - } - } - proc render_erasechar {i count} { - upvar outcols o - upvar understacks ustacks - upvar understacks_gx gxstacks - upvar replay_codes_overlay replay - #ECH clears character attributes from erased character positions - #ECH accepts 0 or empty parameter, which is equivalent to 1. Caller of render_erasechar should do that mapping and only supply 1 or greater. - if {![tcl::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? - #DECECM ??? - set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list $replay]]] - set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]] ;# ??? review - return - } - proc render_setchar {i c } { - upvar outcols o - lset o $i $c - } - - #Initial usecase is for old-terminal hack to add PM-wrapped \b - #review - can be used for other multibyte sequences that occupy one column? - #combiners? diacritics? - proc render_append_to_char {i c} { - upvar outcols o - if {$i > [llength $o]-1} { - error "render_append_to_char cannot append [ansistring VIEW -lf 1 -nul 1 $c] to existing char at index $i while $i >= llength outcols [llength $o]" - } - set existing [lindex $o $i] - if {$existing eq "\0"} { - lset o $i $c - } else { - lset o $i $existing$c - } - } - #is actually addgrapheme? - proc render_addchar {i c sgrstack gx0stack {insert_mode 0}} { - upvar outcols o - upvar understacks ustacks - upvar understacks_gx gxstacks - - # -- --- --- - #this is somewhat of a hack.. probably not really the equivalent of proper reverse video? review - #we should ideally be able to reverse the video of a sequence that already includes SGR reverse/noreverse attributes - upvar reverse_mode do_reverse - #if {$do_reverse} { - # lappend sgrstack [a+ reverse] - #} else { - # lappend sgrstack [a+ noreverse] - #} - - #JMN3 - if {$do_reverse} { - #note we can't just look for \x1b\[7m or \x1b\[27m - # it may be a more complex sequence like \x1b\[0\;\;7\;31m etc - - set existing_reverse_state 0 - set codeinfo [punk::ansi::codetype::sgr_merge $sgrstack -info 1] - set codestate_reverse [dict get $codeinfo codestate reverse] - switch -- $codestate_reverse { - 7 { - set existing_reverse_state 1 - } - 27 { - set existing_reverse_state 0 - } - "" { - } - } - if {$existing_reverse_state == 0} { - set rflip [a+ reverse] - } else { - #reverse of reverse - set rflip [a+ noreverse] - } - #note that mergeresult can have multiple esc (due to unmergeables or non sgr codes) - set sgrstack [list [dict get $codeinfo mergeresult] $rflip] - #set sgrstack [punk::ansi::codetype::sgr_merge [list [dict get $codeinfo mergeresult] $rflip]] - } - - # -- --- --- - - 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 - } - } - } - -} - - - -# -- --- --- --- --- --- --- --- --- --- --- -tcl::namespace::eval overtype { - interp alias {} ::overtype::center {} ::overtype::centre -} - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide overtype [tcl::namespace::eval overtype { - variable version - set version 1.6.5 -}] -return - -#*** !doctools -#[manpage_end] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm index 1e09252d..6bf529eb 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm @@ -6321,7 +6321,10 @@ namespace eval punk { #useful for aliases e.g treemore -> xmore tree proc xmore {args} { if {[llength $args]} { - uplevel #0 [list {*}$args | more] + #more is older and not as featureful as less + #more importantly - at least some implementations (msys on windows) can skip output lines - unknown as to why + #uplevel #0 [list {*}$args | more] + uplevel #0 [list {*}$args | less -X] ;#-X to avoid use of alternate-screen } else { error "usage: punk::xmore args where args are run as {*}\$args | more" } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm index ad2d58f4..15421402 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -3130,10 +3130,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } undt { - #CSI 58:5 UNDERLINE COLOR PALETTE INDEX - #CSI 58 : 5 : INDEX m - #variable TERM_colour_map - #256 colour underline by Xterm name or by integer + # CSI 58:5 UNDERLINE COLOR PALETTE INDEX + # CSI 58 : 5 : INDEX m + # variable TERM_colour_map + # 256 colour underline by Xterm name or by integer #name is xterm name or colour index from 0 - 255 set cc [tcl::string::tolower [tcl::string::range $i 5 end]] if {[tcl::string::is integer -strict $cc] & $cc < 256} { @@ -5202,9 +5202,10 @@ tcl::namespace::eval punk::ansi { #tcl::dict::set codestate_empty undersingle "" #tcl::dict::set codestate_empty underdouble "" #tcl::dict::set codestate_empty undercurly "" - #tcl::dict::set codestate_empty underdottedn "" + #tcl::dict::set codestate_empty underdotted "" #tcl::dict::set codestate_empty underdashed "" + tcl::dict::set codestate_empty blink "" ;#5 or 6 for slow/fast, 25 for off tcl::dict::set codestate_empty reverse "" ;#7 on 27 off tcl::dict::set codestate_empty hide "" ;#8 on 28 off @@ -5234,6 +5235,8 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate_empty fg "" ;#30-37 + 90-97 tcl::dict::set codestate_empty bg "" ;#40-47 + 100-107 + variable metastate_empty + tcl::dict::set metastate_empty underline_active "" ;#a meta state for whether underlines are on|off - values 1,0,"" #misnomer should have been sgr_merge_args ? :/ #as a common case optimisation - it will not merge a single element list, even if that code contains redundant elements @@ -5269,6 +5272,7 @@ tcl::namespace::eval punk::ansi { #(use punk::ansi::ta::split_codes_single) proc sgr_merge_singles {codelist args} { variable codestate_empty + variable metastate_empty variable defaultopts_sgr_merge_singles set opts $defaultopts_sgr_merge_singles foreach {k v} $args { @@ -5284,8 +5288,8 @@ tcl::namespace::eval punk::ansi { } set othercodes [list] - set codestate $codestate_empty - set codestate_initial $codestate_empty ;#keep a copy for resets. + set codestate $codestate_empty ;#take copy as we need the empty state for resets + set metastate $metastate_empty set did_reset 0 #we should also handle 8bit CSI here? mixed \x1b\[ and \x9b ? Which should be used in the merged result? @@ -5345,7 +5349,8 @@ tcl::namespace::eval punk::ansi { switch -- $codeint { "" - 0 { if {![tcl::dict::get $opts -filter_reset]} { - set codestate $codestate_initial + set codestate $codestate_empty + set metastate $metastate_empty set did_reset 1 } } @@ -5371,27 +5376,42 @@ tcl::namespace::eval punk::ansi { #e.g hyper on windows if {[llength $paramsplit] == 1} { tcl::dict::set codestate underline 4 + if {[tcl::dict::get $codestate underextended] eq "4:0"} { + tcl::dict::set codestate underextended "" + } + tcl::dict::set metastate underline_active 1 } else { switch -- [lindex $paramsplit 1] { 0 { #no *extended* underline #tcl::dict::set codestate underline 24 tcl::dict::set codestate underextended 4:0 ;#will not turn off SGR standard underline if term doesn't support extended + tcl::dict::set metastate underline_active 0 } 1 { + #single tcl::dict::set codestate underextended 4:1 + tcl::dict::set metastate underline_active 1 } 2 { + #double tcl::dict::set codestate underextended 4:2 + tcl::dict::set metastate underline_active 1 } 3 { + #curly tcl::dict::set codestate underextended "4:3" + tcl::dict::set metastate underline_active 1 } 4 { + #dotted tcl::dict::set codestate underextended "4:4" + tcl::dict::set metastate underline_active 1 } 5 { + #dashed tcl::dict::set codestate underextended "4:5" + tcl::dict::set metastate underline_active 1 } } @@ -5431,6 +5451,7 @@ tcl::namespace::eval punk::ansi { 24 { tcl::dict::set codestate underline 24 ;#off tcl::dict::set codestate underextended "4:0" ;#review + tcl::dict::set metastate underline_active 0 } 25 { tcl::dict::set codestate blink 25 ;#off @@ -5519,11 +5540,11 @@ tcl::namespace::eval punk::ansi { } 58 { #nonstandard - #256 colour or rgb + # 256 colour or rgb if {[tcl::string::first : $p] < 0} { switch -- [lindex $plist $i+1] { 5 { - #256 - 1 more param + # 256 - 1 more param tcl::dict::set codestate underlinecolour "58\;5\;[lindex $plist $i+2]" incr i 2 } @@ -5544,10 +5565,12 @@ tcl::namespace::eval punk::ansi { 60 { tcl::dict::set codestate ideogram_underline 60 tcl::dict::set codestate ideogram_clear "" + #nounderline effect? review! } 61 { tcl::dict::set codestate ideogram_doubleunderline 61 tcl::dict::set codestate ideogram_clear "" + #nounderline effect? review! } 62 { tcl::dict::set codestate ideogram_overline 62 @@ -5566,6 +5589,7 @@ tcl::namespace::eval punk::ansi { #review - we still need to pass through the ideogram_clear in case something understands it tcl::dict::set codestate ideogram_underline "" tcl::dict::set codestate ideogram_doubleunderline "" + tcl::dict::set codestate ideogram_overline "" tcl::dict::set codestate ideogram_doubleoverline "" } @@ -5623,6 +5647,7 @@ tcl::namespace::eval punk::ansi { } } underlinecolour - underextended { + #review append unmergeable "${v}\;" } default { @@ -5640,7 +5665,11 @@ tcl::namespace::eval punk::ansi { "" {} default { switch -- $k { - underlinecolour - underextended { + underlinecolour { + append unmergeable "${v}\;" + } + underextended { + #review append unmergeable "${v}\;" } default { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm deleted file mode 100644 index 91f29aa5..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm +++ /dev/null @@ -1,5314 +0,0 @@ -# -*- 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: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.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 punk::args 0.1.0 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.1.0] -#[copyright "2024"] -#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] -#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] -#[require punk::args] -#[keywords module proc args arguments parse] -#[description] -#[para]Utilities for parsing proc args - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). -#[para] overview of punk::args -#[subsection Concepts] -#[para]There are 2 main conventions for parsing a proc args list -#[list_begin enumerated] -#[enum] -#[para]leading option-value pairs and flags followed by a list of values (Tcl style) -#[enum] -#[para]leading list of values followed by option-value pairs and flags (Tk style) -#[list_end] -#[para]There are exceptions in both Tcl and Tk commands regarding this ordering -#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style -#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] -#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. -#[para] -#[para]The basic principle is that a call to punk::args::get_dict is made near the beginning of the proc with a cacheable first argument defining the parameters e.g -#[example { -# proc dofilestuff {args} { -# lassign [dict values [punk::args::get_dict { -# @cmd -help "do some stuff with files e.g dofilestuff " -# @opts -type string -# #comment lines ok -# -directory -default "" -# -translation -default binary -# #setting -type none indicates a flag that doesn't take a value (solo flag) -# -nocomplain -type none -# @values -min 1 -max -1 -# } $args]] leaders opts values -# -# puts "translation is [dict get $opts -translation]" -# foreach f [dict values $values] { -# puts "doing stuff with file: $f" -# } -# } -#}] -#[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls -#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values -#[para]valid @ lines being with @cmd @leaders @opts @values -#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. -#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. -#[para]e.g the result from the punk::args call above may be something like: -#[para] opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} -#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments -#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments -#[example { -# proc dofilestuff {category args} { -# lassign [dict values [punk::args::get_dict { -# -directory -default "" -# -translation -default binary -# -nocomplain -type none -# @values -min 2 -max 2 -# fileA -type existingfile 1 -# fileB -type existingfile 1 -# } $args]] leaders opts values -# puts "$category fileA: [dict get $values fileA]" -# puts "$category fileB: [dict get $values fileB]" -# } -#}] -#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 -#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored -#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, -#[para] or an additional call could be made to punk::args e.g -#[example { -# punk::args::get_dict { -# category -choices {cat1 cat2 cat3} -# another_leading_arg -type boolean -# } [list $category $another_leading_arg] -#}] - -#*** !doctools -#[subsection Notes] -#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. -#[para] -#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. -#For functions that are part of an API a package may be more suitable. -#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) -#[example { -# proc test_switch {args} { -# set opts [dict create\\ -# -return "object"\\ -# -frametype "heavy"\\ -# -show_edge 1\\ -# -show_seps 0\\ -# -x a\\ -# -y b\\ -# -z c\\ -# -1 1\\ -# -2 2\\ -# -3 3\\ -# ] -# foreach {k v} $args { -# switch -- $k { -# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { -# dict set opts $k $v -# } -# default { -# error "unrecognised option '$k'. Known options [dict keys $opts]" -# } -# } -# } -# return $opts -# } -#}] -#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. -#[para] -# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. -# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. -#[para]use punk::lib::show_jump_tables to verify that a jump table exists. -#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous -#[example { -# proc test_prefix {args} { -# set opts [dict create\ -# -return string\ -# -frametype \uFFEF\ -# -show_edge \uFFEF\ -# -show_seps \uFFEF\ -# -x a\ -# -y b\ -# -z c\ -# -1 1\ -# -2 2\ -# -3 3\ -# ] -# if {[llength $args]} { -# set knownflags [dict keys $opts] -# } -# foreach {k v} $args { -# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v -# } -# return $opts -# } -#}] -#[para]There are many alternative args parsing packages a few of which are listed here. -#[list_begin enumerated] -#[enum]argp (pure tcl) -#[enum]parse_args (c implementation) -#[enum]argparse (pure tcl *) -#[enum]cmdline (pure tcl) -#[enum]opt (pure tcl) distributed with Tcl but considered deprecated -#[enum]The tcllib set of TEPAM modules (pure tcl) -#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. -#[list_end] -#[para] (* c implementation planned/proposed) -#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. -#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences -#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. -#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. -#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. -#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. -#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -#All ensemble commands are slower in a safe interp as they aren't compiled the same way -#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 -#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. -#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) -#ensembles: array binary clock dict info namespace string -#possibly file too, although that is generally hidden/modified in a safe interp -#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc -#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::args -#[list_begin itemized] -package require Tcl 8.6- -#optional? punk::trie -#optional? punk::textblock -#*** !doctools -#[item] [package {Tcl 8.6-}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -tcl::namespace::eval punk::args::register { - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] cooperative namespace punk::args::register - #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded - #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. - #[list_begin definitions] - - #Although the actual punk::args::define calls are not too sluggish, there could be *many*. - #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, - #especially since a fair proportion may be for documentation purposes rather than parsing args. - - # -- --- --- --- --- --- --- --- - #cooperative with packages that define some punk args but do so lazily - #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first - variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective - if {![info exists ::punk::args::register::NAMESPACES]} { - set ::punk::args::register::NAMESPACES [list] - } - # -- --- --- --- --- --- --- --- - - variable loaded_packages [list] ;#fully loaded - variable loaded_info [dict create] ;#time - variable scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages - variable scanned_info [dict create] ;#time and idcount - #some packages, e.g punk::args::tclcore document other namespaces. - #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources - variable namespace_docpackages [dict create] - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::register ---}] -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args { - - - variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. - - tcl::namespace::export {[a-z]*} - variable rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} - variable id_cache_rawdef [tcl::dict::create] - variable id_cache_spec [tcl::dict::create] - - variable argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) - - variable argdata_cache [tcl::dict::create] - - variable id_counter 0 - - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] Core API functions for punk::args - #[list_begin definitions] - - #todo - some sort of punk::args::cherrypick operation to get spec from an existing set - #todo - doctools output from definition - - - - - #todo? -synonym/alias ? (applies to opts only not values) - #e.g -background -aliases {-bg} -default White - #review - how to make work with trie prefix - #e.g - # -corner -aliases {-corners} - # -centre -aliases {-center -middle} - #We mightn't want the prefix to be longer just because of an alias - #we should get -co -ce and -m from the above as abbreviations - - set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] - - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::define - #todo @preamble -help "move large block outside of table?" - @cmd -name punk::args::define -help\ - "Accepts a line-based definition of command arguments. - Returns a dictionary representing the argument specifications. - - The return result can generally be ignored, as the record is stored keyed on the - @id -id value from the supplied definition. - This specifications dictionary is structured for (optional) use within commands to - parse and validate the arguments - and is also used when retrieving definitions - (or parts thereof) for re-use. - - This can be used purely for documentation or called within a function to parse a mix - of leading values, switches/flags and trailing values. - - The overhead is favourably comparable with other argument processors - but none are - as fast as minimal code with a switch statement. For toplevel commands where a few - 10s of microseconds is immaterial, the validation and automated error formatting in - a table can be well worthwhile. For inner procs requiring utmost speed, the call can - be made only on the unhappy path when basic processing determines a mismatch - or it - can be left entirely as documentation for interactive use with: i ... - - The definition should usually contain an initial line of the form: @id -id ::somecmd - - Blank lines are ignored at the top level, ie if they are not part of another structure. - Similarly - lines at the top level begginning with the # character are ignored. - All other toplevel lines must consist of a leading word followed by paired arguments. - The arguments can be spread over multiple lines and contain lines of near-arbitrary - text if they are properly braced or double quoted and Tcl escaping for inner quotes - or unbalanced braces is maintained. - The line continuation character - (\\ at the end of the line) can be used to continue the set of arguments for - a leading word. - Leading words beginning with the @ character are directives controlling argument - parsing and help display. - directives include: - %B%@id%N% ?opt val...? - spec-options: -id - %B%@cmd%N% ?opt val...? - spec-options: -name -help - %B%@leaders%N% ?opt val...? - spec-options: -min -max - (used for leading args that come before switches/opts) - %B%@opts%N% ?opt val...? - spec-options: -any - %B%@values%N% ?opt val...? - spec-options: -min -max - (used for trailing args that come after switches/opts) - %B%@argdisplay%N% ?opt val...? - spec-options: -header (text for header row of table) - -body (text to replace autogenerated arg info) - %B%@doc%N% ?opt val...? - spec-options: -name -url - %B%@seealso%N% ?opt val...? - spec-options: -name -url (for footer - unimplemented) - - Some other spec-options normally present on custom arguments are available - to use with the @leaders @opts @values directives to set defaults - for subsequent lines that represent your custom arguments. - These directives should occur in exactly this order - but can be - repeated with custom argument lines interspersed. - - An @id line can only appear once and should be the first item. - For the commandline usage to be displayed either on parsing error - or using the i .. function - an @id with -id is needed. - - All directives can be omitted, in which case every line represents - a custom leader, value or option. - All will be leaders by default if no options defined. - If options are defined (by naming with leading dash, or explicitly - specifying @opts) then the definitions prior to the options will be - categorised as leaders, and those following the options will be - categorised as values. - - Custom arguments are defined by using any word at the start of a - line that doesn't begin with @ or - - (except that adding an additionl @ escapes this restriction so - that @@somearg becomes an argument named @somearg) - - custom leading args, switches/options (names starting with -) - and trailing values also take spec-options: - - -type - defaults to string. If no other restrictions - are specified, choosing string does the least validation. - recognised types: - none - (used for switches only. Indicates this is - a 'solo' flag ie accepts no value) - int|integer - list - dict - double - bool|boolean - char - file - directory - string - ansistring - globstring - (any of the types accepted by 'string is') - - These all perform some validation checks - - and more.. (todo - document here) - - -optional - (defaults to true for flags/switches false otherwise) - For non flag/switch arguments - all arguments with - -optional true must sit consecutively within their group. - ie all optional leader arguments must be together, and all - optional value arguments must be together. Furthermore, - specifying both optional leaders and optional values will - often lead to ambiguous parsing results. Currently, all - optional non-flg/switch arguments should be either at the - trailing end of leaders or the trailing end of values. - Further unambiguous arrangements of optional args may be - made in future - but are currently considered 'unsupported' - -default - -multiple (for leaders & values defines whether - subsequent received values are stored against the same - argument name - only applies to final leader OR final value) - (for options/flags this allows the opt-val pair or solo - flag to appear multiple times - not necessarily contiguously) - -choices {} - A list of allowable values for an argument. - The -default value doesn't have to be in the list. - If a -type is specified - it doesn't apply to choice members. - It will only be used for validation if the -choicerestricted - option is set to false. - -choicerestricted - Whether values not specified in -choices or -choicegroups are - allowed. Defaults to true. - -choiceprefix - This specifies whether unique prefixes are able to be used - instead of the complete string. This is calculated using - tcl::prefix::match - and will display in the autogenerated - usage output. Defaults to true. - -choiceprefixdenylist {} - These choices should match exactly a choice entry in one of - the settings -choices or -choicegroups. - These will still be used in prefix calculation - but the full - choice argument must be entered to select the choice. - -choicegroups {} - Generally this would be used instead of -choices to allow - usage display of choices grouped by some name. - See for example the output if 'i zlib' where choices of the - next subcommand are grouped by the names compression,channel, - streaming and checksumming. The -choices list is equivalent - to a -choicegroups dict entry where the key (groupname) is - the empty string. - -choicemultiple (default {1 1}) - is a pair representing min and max number of choices - that can be present in the value. - If is a single integer it is equivalent to a - specified with the same integer for both min and max. - Max of -1 represents no upper limit. - If allows more than one choice the value is a list - consisting of items in the choices made available through - entries in -choices/-choicegroups. - -minsize (type dependant) - -maxsize (type dependant) - -range (type dependant) - - - " - -dynamic -type boolean -default 0 -help\ - "If -dynamic is true, tstr interpolations of the form \$\{\$var\} - are re-evaluated on each call. - If the definition is being used not just as documentation, but is also - used within the function to parse args, e.g using punk::args::get_by_id, - then it should be noted that there is a slight performance penalty for the - dynamic case. - It is often not significant, perhaps depending on what vars/commands are - used but -dynamic true might be less desirable if the command is used in - inner loops in more performance-sensitive code. - " - @values -min 1 -max -1 - text -type string -multiple 1 -help\ - "Block(s) of text representing the argument definition for a command. - At least one must be supplied. If multiple, they are joined together with \\n. - Using multiple text arguments may be useful to mix curly-braced and double-quoted - strings to have finer control over interpolation when defining arguments. - (this can also be handy for sections that pull resolved definition lines - from existing definitions (by id) for re-use of argument specifications and help text) - - e.g the following definition passes 2 blocks as text arguments - definition { - @id -id ::myns::myfunc - @cmd -name myns::myfunc -help\\ - \"Description of command\" - - #The following option defines an option-value pair - -option1 -default blah -type string - #The following option defines a flag style option (solo) - -flag1 -default 0 -type none -help\\ - \"Info about flag1 - subsequent help lines auto-dedented by whitespace to left - of corresponding record start (in this case -flag1) - + first 4 spaces if they are all present. - This line has no extra indent relative to first line 'Info about flag1' - This line indented a further 6 chars\" - - @values -min 1 -max -1 - #Items that don't begin with * or - are value definitions - v1 -type integer -default 0 - thinglist -type string -multiple 1 - } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" - " - }]] - - proc New_command_form {name} { - #probably faster to inline a literal dict create in the proc than to use a namespace variable - set leaderspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - set optspec_defaults [tcl::dict::create\ - -type string\ - -optional 1\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - set valspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - - #form record can have running entries such as 'argspace' that aren't given to arg parser - #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict - return [dict create\ - argspace "leaders"\ - ARG_INFO [tcl::dict::create]\ - ARG_CHECKS [tcl::dict::create]\ - LEADER_DEFAULTS [tcl::dict::create]\ - LEADER_REQUIRED {}\ - LEADER_NAMES {}\ - LEADER_MIN ""\ - LEADER_MAX ""\ - leaderspec_defaults $leaderspec_defaults\ - LEADER_CHECKS_DEFAULTS {}\ - opt_default {}\ - opt_required {}\ - OPT_NAMES {}\ - opt_any {}\ - opt_solos {}\ - optspec_defaults $optspec_defaults\ - OPT_CHECKS_DEFAULTS {}\ - val_defaults {}\ - val_required {}\ - VAL_NAMES {}\ - val_min ""\ - val_max ""\ - valspec_defaults $valspec_defaults\ - VAL_CHECKS_DEFAULTS {}\ - argdisplay_info ""\ - ] - - #set argdata_dict [tcl::dict::create\ - # id $DEF_definition_id\ - # arg_info $arg_info\ - # arg_checks $arg_checks\ - # leader_defaults $leader_defaults\ - # leader_required $leader_required\ - # leader_names $leader_names\ - # leader_min $leader_min\ - # leader_max $leader_max\ - # leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ - # leader_checks_defaults $leader_checks_defaults\ - # opt_defaults $opt_defaults\ - # opt_required $opt_required\ - # opt_names $opt_names\ - # opt_any $opt_any\ - # opt_solos $opt_solos\ - # optspec_defaults [dict get $F $firstformid optspec_defaults]\ - # opt_checks_defaults $opt_checks_defaults\ - # val_defaults $val_defaults\ - # val_required $val_required\ - # val_names $val_names\ - # val_min $val_min\ - # val_max $val_max\ - # valspec_defaults [dict get $F $firstformid valspec_defaults]\ - # val_checks_defaults $val_checks_defaults\ - # cmd_info $cmd_info\ - # doc_info $doc_info\ - # argdisplay_info $argdisplay_info\ - # id_info $id_info\ - # form_defs $F\ - #] - } - proc define {args} { - dict get [resolve {*}$args] id - } - proc resolve {args} { - variable rawdef_cache - variable id_cache_rawdef - if {[dict exists $rawdef_cache $args]} { - set id [dict get $rawdef_cache $args -id] - set is_dynamic [dict get $rawdef_cache $args -dynamic] - } else { - set id [rawdef_id $args] - set is_dynamic [rawdef_is_dynamic $args] - dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] - dict set id_cache_rawdef $id $args - } - - - variable argdata_cache - variable argdefcache_unresolved - - - set cache_key $args - #ideally we would use a fast hash algorithm to produce a short key with low collision probability. - #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) - #review - check if there is a built-into-tcl way to do this quickly - #for now we will just key using the whole string - #performance seems ok - memory usage probably not ideal - #quote from DKF 2021 - #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. - #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. - #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. - #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). - #> If dealing with very large amounts of data, using a database is probably a good plan. - - set textargs $args - if {![llength $args]} { - punk::args::get_by_id ::punk::args::define {} - return - } - if {[lindex $args 0] eq "-dynamic"} { - set is_dynamic [lindex $args 1] - set textargs [lrange $args 2 end] - } - - if {!$is_dynamic} { - if {[tcl::dict::exists $argdata_cache $cache_key]} { - return [tcl::dict::get $argdata_cache $cache_key] - } - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - if {[string first \$\{ $optionspecs] > 0} { - set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } - } else { - #we are always doing our first subst during the define.. shouldn't it be a separate resolve somehow? optionally so at least? - - if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { - set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel 1 [list ::subst $param]] - } - } else { - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) - if {[string first \$\{ $optionspecs] > 0} { - set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel 1 [list ::subst $param]] - } - tcl::dict::set argdefcache_unresolved $cache_key $pt_params - } - } - #argdata_cache should be limited in some fashion or will be a big memory leak??? - if {[tcl::dict::exists $argdata_cache $optionspecs]} { - #resolved cache version exists - return [tcl::dict::get $argdata_cache $optionspecs] - } - } - - - - #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices - #default to 1 for convenience - - #checks with no default - #-minsize -maxsize -range - - - #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi - #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist - set opt_required [list] - set val_required [list] - - set opt_defaults [tcl::dict::create] - - set val_defaults [tcl::dict::create] - set opt_solos [list] - #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end - - set records [list] - set linebuild "" - - set linelist [split $optionspecs \n] - set lastindent "" - foreach ln $linelist { - if {[tcl::string::trim $ln] eq ""} {continue} - regexp {(\s*).*} $ln _all lastindent - break ;#break at first non-empty - } - #puts "indent1:[ansistring VIEW $lastindent]" - set in_record 0 - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - foreach rawline $linelist { - set recordsofar [tcl::string::cat $linebuild $rawline] - #ansi colours can stop info complete from working (contain square brackets) - #review - when exactly are ansi codes allowed/expected in record lines. - # - we might reasonably expect them in default values or choices or help strings - # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. - # - eg set line "set x \"a[a+ red]red[a]\"" - # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket - if {$has_punkansi} { - set test_complete [punk::ansi::ansistrip $recordsofar] - } else { - #review - #we only need to strip enough to stop interference with 'info complete' - set test_complete [string map [list \x1b\[ ""] $recordsofar] - } - if {![tcl::info::complete $test_complete]} { - #append linebuild [string trimleft $rawline] \n - if {$in_record} { - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. - #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. - #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. - #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) - #(note string first "" $str is fast and returns -1) - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline \n - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline \n - } else { - append linebuild $rawline \n - } - } else { - set in_record 1 - regexp {(\s*).*} $rawline _all lastindent - #puts "indent: [ansistring VIEW -lf 1 $lastindent]" - #puts "indent from rawline:$rawline " - append linebuild $rawline \n - } - } else { - set in_record 0 - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline - } else { - append linebuild $rawline - } - lappend records $linebuild - set linebuild "" - } - } - set cmd_info {} - set package_info {} - set id_info {} ;#e.g -children ?? - set doc_info {} - set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table - set seealso_info {} - set keywords_info {} - ###set leader_min 0 - ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit - #set leader_max "" - #(common case of no leaders specified) - set opt_any 0 - set val_min 0 - set val_max -1 ;#-1 for no limit - set DEF_definition_id $id - - #form_defs - set F [dict create _default [New_command_form _default]] - set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under - - #set ARGSPACE [dict create] ;#keyed on form - #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values - - set refs [dict create] - set record_type "" - set record_number -1 ;# - foreach rec $records { - set trimrec [tcl::string::trim $rec] - switch -- [tcl::string::index $trimrec 0] { - "" - # {continue} - } - incr record_number - set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict - if {[llength $record_values] % 2 != 0} { - #todo - avoid raising an error - store invalid defs keyed on id - error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" - } - # ---------------------------------------------------------- - # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. - #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! - #(form_ids_active is otherwise set in the @form handling block) - - #consider the following 2 line entry which is potentially dynamically included via a tstr: - # @form -form {* newform} - # @form -form {newform} -synopsis "cmd help ?stuff?" - #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. - #(because _default is usually 'taken over' by the first encountered form id) - #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record - #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. - - if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { - set patterns [dict get $record_values -form] - set record_form_ids [list] - foreach p $patterns { - if {[regexp {[*?\[\]]} $p]} { - #isglob - only used for matching existing forms - lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] - } else { - #don't test for existence - will define new form if necessary - lappend record_form_ids $p - } - } - #-form values could be globs that didn't match. record_form_ids could be empty.. - if {[llength $record_form_ids]} { - #only rename _default if it's the sole entry - if {[dict size $F] == 1 && [dict exists $F "_default"]} { - if {"_default" ni $record_form_ids} { - #only initial form exists - but we are mentioning new ones - #first rename the _default to first encountered new form id - #(just replace whole dict with new key - same data) - set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] - #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F - #we are only setting active because of the rename - @form is the way to change active forms list - set form_ids_active [lindex $record_form_ids 0] - } - } - foreach fid $record_form_ids { - if {![dict exists $F $fid]} { - if {$firstword eq "@form"} { - #only @form directly supplies keys - dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] - } else { - dict set F $fid [New_command_form $fid] - } - } else { - #update form with current record opts, except -form - if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } - } - } - } - } else { - #missing or empty -form - set record_form_ids $form_ids_active - if {$firstword eq "@form"} { - foreach fid $form_ids_active { - dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] - } - } - } - # ---------------------------------------------------------- - - set firstchar [tcl::string::index $firstword 0] - set secondchar [tcl::string::index $firstword 1] - if {$firstchar eq "@" && $secondchar ne "@"} { - set record_type "directive" - set directive_name $firstword - set at_specs $record_values - - switch -- [tcl::string::range $directive_name 1 end] { - dynamic { - set is_dynamic 1 - } - id { - #disallow duplicate @id line ? - #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) - - #id An id will be allocated if no id line present or the -id value is "auto" - - if {[dict exists $at_specs -id]} { - set thisid [dict get $at_specs -id] - if {$thisid ni [list $id auto]} { - error "punk::args::define @id mismatch existing: $id vs $thisid" - } - } - set id_info $at_specs - } - ref { - #a reference within the definition - #e.g see punk::args::tclcore ::after - #global reference dict - independent of forms - #ignore refs without an -id - #store all keys except -id - #complete overwrite if refid repeated later on - if {[dict exists $at_specs -id]} { - dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] - } - } - default { - #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple - #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) - #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) - #That is possibly too complicated and/or unnecessary? - #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? - - if {[dict exists $at_specs -id]} { - set copyfrom [get_spec [dict get $at_specs -id]] - #we don't copy the @id info from the source - #for now we only copy across if nothing set.. - #todo - bring across defaults for empty keys at targets? - #need to keep it simple enough to reason about behaviour easily.. - if {[dict size $copyfrom]} { - if {![dict size $cmd_info]} { - set cmd_info [dict get $copyfrom cmd_info] - } - if {![dict size $doc_info]} { - set doc_info [dict get $copyfrom doc_info] - } - foreach fid $record_form_ids { - #only use elements with matching form id? - #probably this feature mainly useful for _default anyway so that should be ok - #cooperative doc sets specified in same file could share via known form ids too - #todo argdisplay_info by fid - if {![dict size $argdisplay_info]} { - set argdisplay_info [dict get $copyfrom argdisplay_info] - } - #TODO - #create leaders opts vals depending on position of @default line? - #options on @default line to exclude/include sets??? - } - } - } - } - form { - # arity system ? - #handle multiple parsing styles based on arities and keyword positions (and/or flags?) - #e.g see lseq manual with 3 different parsing styles. - #aim to produce a table/subtable for each - # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ - # -arities { - # 2 - # {3 anykeys {1 .. 1 to}} - # {4 anykeys {3 by}} - # {5 anykeys {1 .. 1 to 3 by}} - # }\ - # -fallback 1 - # ... - # @parser -synopsis "start 'count' count ??'by'? step?"\ - # -arities { - # {3 anykeys {1 count}} - # } - # ... - # @form -synopsis "count ?'by' step?"\ - # -arities { - # 1 - # {3 anykeys {1 by}} - # } - # - # see also after manual - # @form -arities {1} - # @form -arities { - # 1 anykeys {0 info} - # } - #todo - - #can we generate a form synopsis if -synopsis not supplied? - - #form id can be list of ints|names?, or * - if {[dict exists $at_specs -form]} { - set idlist [dict get $at_specs -form] - if {$idlist eq "*"} { - #* only applies to form ids that exist at the time - set idlist [dict keys $F] - } - set form_ids_active $idlist - } - #new form keys already created if they were needed (done for all records that have -form ) - } - package { - set package_info [dict merge $package_info $at_specs] - } - cmd { - #allow arbitrary - review - set cmd_info [dict merge $cmd_info $at_specs] - } - doc { - set doc_info [dict merge $doc_info $at_specs] - } - argdisplay { - #override the displayed argument table. - #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing - set argdisplay_info [dict merge $argdisplay_info $at_specs] - } - opts { - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "values"} { - error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" - } - dict set F $fid argspace "options" - set tmp_optspec_defaults [dict get $F $fid optspec_defaults] - - foreach {k v} $at_specs { - switch -- $k { - -any - - -anyopts { - set opt_any $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { - #review - only apply to certain types? - tcl::dict::set tmp_optspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_optspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - none - "" - - - any - ansistring - globstring - list { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_optspec_defaults -type $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - #allow overriding of defaults for options that occur later - tcl::dict::set tmp_optspec_defaults $k $v - } - default { - set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" - } - } - } - dict set F $fid optspec_defaults $tmp_optspec_defaults - } ;# end foreach record_form_ids - } - leaders { - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] in [list options values]} { - error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" - } - set tmp_leaderspec_defaults [dict get $F $fid leaderspec_defaults] - - foreach {k v} $at_specs { - switch -- $k { - -min - - -minvalues { - if {$v < 0} { - error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MIN $v - #if {$leader_max == 0} { - # set leader_max -1 - #} - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MAX $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -choiceinfo { - if {[llength $v] %2 != 0} { - error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - #-choicegroups? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_leaderspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set tmp_leaderspec_defaults $k $v - } - default { - set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid leaderspec_defaults $tmp_leaderspec_defaults - - } ;#end foreach record_form_ids - - } - values { - foreach fid $record_form_ids { - dict set F $fid argspace "values" - - set tmp_valspec_defaults [dict get $F $fid valspec_defaults] - - foreach {k v} $at_specs { - switch -- $k { - -form { - } - -min - - -minvalues { - if {$v < 0} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" - } - set val_min $v - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" - } - set val_max $v - } - -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_valspec_defaults $k $v - } - -choiceinfo - -choicegroups { - if {[llength $v] % 2 != 0} { - error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - # -choicegroups ?? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_valspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set tmp_valspec_defaults $k $v - } - default { - set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid valspec_defaults $tmp_valspec_defaults - } - - } - seealso { - #todo! - #like @doc, except displays in footer, multiple - sub-table? - set seealso_info [dict merge $seealso_info $at_specs] - } - keywords { - #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? - set keywords_info [dict merge $keywords_info $at_specs] - } - default { - error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @argdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" - } - } - #record_type directive - continue - } elseif {$firstchar eq "-"} { - set argname $firstword - set argdef_values $record_values - tcl::dict::set argdef_values -ARGTYPE option - - - - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - dict set F $fid argspace "options" - } elseif {[dict get $F $fid argspace] eq "values"} { - error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" - } - set record_type option - dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] - #lappend opt_names $argname - } - - set is_opt 1 - } else { - set argname $firstword - if {$firstchar eq "@"} { - #allow basic @@ escaping for literal argname that begins with @ - set argname [tcl::string::range $argname 1 end] - } - - set argdef_values $record_values - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - set record_type leader - tcl::dict::set argdef_values -ARGTYPE leader - #lappend leader_names $argname - set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] - if {$argname ni $temp_leadernames} { - lappend temp_leadernames $argname - tcl::dict::set F $fid LEADER_NAMES $temp_leadernames - } else { - error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" - } - - if {[dict get $F $fid LEADER_MAX] >= 0} { - dict set F $fid LEADER_MAX [llength $temp_leadernames] - } - } else { - set record_type value - tcl::dict::set argdef_values -ARGTYPE value - set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] - lappend temp_valnames $argname - tcl::dict::set F $fid VAL_NAMES $temp_valnames - #lappend val_names $argname - } - } - - set is_opt 0 - } - - - #assert - we only get here if it is a value or flag specification line. - #assert argdef_values has been set to the value of record_values - - foreach fid $record_form_ids { - if {$is_opt} { - set spec_merged [dict get $F $fid optspec_defaults] - } else { - if {[dict get $F $fid argspace] eq "values"} { - set spec_merged [dict get $F $fid valspec_defaults] - } else { - set spec_merged [dict get $F $fid leaderspec_defaults] - } - } - - # -> argopt argval - foreach {spec specval} $argdef_values { - #literal-key switch - bytecompiled to jumpTable - switch -- $spec { - -form { - - } - -type { - #normalize here so we don't have to test during actual args parsing in main function - switch -- [tcl::string::tolower $specval] { - int - integer { - tcl::dict::set spec_merged -type int - } - bool - boolean { - tcl::dict::set spec_merged -type bool - } - char - character { - tcl::dict::set spec_merged -type char - } - dict - dictionary { - tcl::dict::set spec_merged -type dict - } - "" - none { - if {$is_opt} { - tcl::dict::set spec_merged -type none - 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 - error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" - } - } - any - anything { - tcl::dict::set spec_merged -type any - } - ansi - ansistring { - tcl::dict::set spec_merged -type ansistring - } - any - string - globstring { - tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - } - default { - #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW - tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - } - } - } - -default - -solo - -range - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo - - -minsize - -maxsize - -nocase - -optional - -multiple - - -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - - -regexprepass - -regexprefail - -regexprefailmsg - { - #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines - #review -solo 1 vs -type none ? conflicting values? - tcl::dict::set spec_merged $spec $specval - } - -validationtransform { - #string is dict only 8.7/9+ - if {[llength $specval] % 2} { - error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" - } - dict for {tk tv} $specval { - switch -- $tk { - -function - -type - -minsize - -maxsize - -range { - } - default { - set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? - error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" - } - } - } - - } - default { - if {[string match ref-* $spec]} { - #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) - #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. - if {![tcl::dict::exists $refs $specval]} { - puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" - } else { - set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" - if {$targetswitch eq "-*"} { - set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id - } else { - if {[tcl::dict::exists $refs $specval $targetswitch]} { - tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] - } else { - puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" - } - } - } - } else { - set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - ] - error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" - } - } - } - } ;# end foreach {spec specval} argdef_values - - - if {$is_opt} { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } else { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - tcl::dict::set F $fid ARG_INFO $argname $spec_merged - #review existence of -default overriding -optional - if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { - if {$is_opt} { - lappend opt_required $argname - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - set temp_leader_required [dict get $F $fid LEADER_REQUIRED] - lappend temp_leader_required $argname - dict set F $fid LEADER_REQUIRED $temp_leader_required - #lappend leader_required $argname - } else { - lappend val_required $argname - } - } - } - if {[tcl::dict::exists $spec_merged -default]} { - if {$is_opt} { - tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } else { - tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] - } - } - } - } ;# end foreach fid record_form_ids - - } ;# end foreach rec $records - - - #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { - # variable id_counter - # set DEF_definition_id "autoid_[incr id_counter]" - #} - - - #check ALL forms not just form_ids_active (record_form_ids) - dict for {fid formdata} $F { - # REVIEW - #no values specified - we can allow last leader to be multiple - foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { - error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" - } - } - #confirm any valnames before last don't have -multiple key - foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { - error "bad key -multiple on argument spec for value '$valname' in command form:'$fid'. Only the last value argument specification can be marked -multiple @id:$DEF_definition_id" - } - } - - #todo - document that ambiguities in API are likely if both @leaders and @values used - #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) - - - dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - - - - - #todo - precalculate a set of 'arity' entries for each form - #We want a structure for the arg parser to get easy access and make a fast decision on which form applies - #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? - #1) after ms (1 1) - #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? - #3) after cancel id (2 2) - #4) after cancel script ?script...? (2 -1) - #5) after idle script ?script...? (1 -1) - #6) after info ?id? (1 2) - - #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) - - #in the above case we have no unique total_arity - #we would also want to consider values when selecting - #e.g given the invalid command "after cancel" - # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. - - - - set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands - #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use - #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form - #e.g commandline completion could show list of synopsis entries to select from - - set form_info [dict create] - dict for {fid fdict} $F { - dict set form_info $fid {} - dict for {optk optv} $fdict { - if {[string match -* $optk]} { - dict set form_info $fid $optk $optv - } - } - } - - set argdata_dict [tcl::dict::create\ - id $DEF_definition_id\ - ARG_INFO [dict get $F $firstformid ARG_INFO]\ - ARG_CHECKS [dict get $F $firstformid ARG_CHECKS]\ - LEADER_DEFAULTS [dict get $F $firstformid LEADER_DEFAULTS]\ - LEADER_REQUIRED [dict get $F $firstformid LEADER_REQUIRED]\ - LEADER_NAMES [dict get $F $firstformid LEADER_NAMES]\ - LEADER_MIN [dict get $F $firstformid LEADER_MIN]\ - LEADER_MAX [dict get $F $firstformid LEADER_MAX]\ - leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ - LEADER_CHECKS_DEFAULTS [dict get $F $firstformid LEADER_CHECKS_DEFAULTS]\ - opt_defaults $opt_defaults\ - opt_required $opt_required\ - OPT_NAMES [dict get $F $firstformid OPT_NAMES]\ - opt_any $opt_any\ - opt_solos $opt_solos\ - optspec_defaults [dict get $F $firstformid optspec_defaults]\ - OPT_CHECKS_DEFAULTS [dict get $F $firstformid OPT_CHECKS_DEFAULTS]\ - val_defaults $val_defaults\ - val_required $val_required\ - VAL_NAMES [dict get $F $firstformid VAL_NAMES]\ - val_min $val_min\ - val_max $val_max\ - valspec_defaults [dict get $F $firstformid valspec_defaults]\ - VAL_CHECKS_DEFAULTS [dict get $F $firstformid VAL_CHECKS_DEFAULTS]\ - cmd_info $cmd_info\ - doc_info $doc_info\ - package_info $package_info\ - argdisplay_info $argdisplay_info\ - seealso_info $seealso_info\ - id_info $id_info\ - FORMS $F\ - form_names [dict keys $F]\ - FORM_INFO $form_info\ - ] - - tcl::dict::set argdata_cache $cache_key $argdata_dict - if {$is_dynamic} { - #also cache resolved version - tcl::dict::set argdata_cache $optionspecs $argdata_dict - } - - #tcl::dict::set id_cache_rawdef $DEF_definition_id $args - #puts "xxx:$result" - return $argdata_dict - } - - #return raw definition list as created with 'define' - # - possibly with unresolved dynamic parts - proc raw_def {id} { - variable id_cache_rawdef - set realid [real_id $id] - if {![dict exists $id_cache_rawdef $realid]} { - return "" - } - return [tcl::dict::get $id_cache_rawdef $realid] - } - - - namespace eval argdoc { - variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @argdisplay @seealso @leaders @opts @values leaders opts values} - variable resolved_def_TYPE_CHOICEGROUPS { - directives {@id @package @cmd @ref @doc @argdisplay @seealso} - argumenttypes {leaders opts values} - remaining_defaults {@leaders @opts @values} - } - - lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { - @id -id ::punk::args::resolved_def - @cmd -name punk::args::resolved_def -help\ - "Resolves or retrieves the previously resolved definition and - uses the 'spec' form to build a response in definition format. - - Pulling argument definition data from another function is a form - of tight coupling to the other function that should be done with - care. - - Note that the directives @leaders @opts @values may appear multiple - times in a source definition - applying defaults for arguments that - follow. When retrieving these - there is only a single result for - each that represents the defaults after all have been applied. - When retrieving -types * each of these will be positioned before - the arguments of that type - but this doesn't mean there was a single - leading directive for this argument type in the source definition. - Each argument has already had its complete specification recorded in - its own result. - - When manually specifying -types, the order @leaders then @opts then - @values must be maintained - but if they are placed before their - corresponding arguments, they will not affect the retrieved arguments - as these arguments are already fully spec'd. The defaults from the - source can be removed by adding @leaders, @opts @values to the - -antiglobs list, but again - this won't affect the existing arguments. - Each argument can have members of its spec overridden using the - -override dictionary. - " - @leaders -min 0 -max 0 - @opts - -return -default text -choices {text dict} - -form -default 0 -help\ - "Ordinal index or name of command form" - - #no restriction on number of types/repetitions? - -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} - -antiglobs -default {} -type list -help\ - "Glob patterns for directive or argument/flags to - be suppressed" - -override -type dict -optional 1 -default "" -help\ - "dict of dicts. Key in outer dict is the name of a - directive or an argument. Inner dict is a map of - overrides/additions (- ...) for that line. - " - @values -min 1 -max -1 - id -type string -help\ - "identifer for a punk::args definition - This will usually be a fully-qualifed - path for a command name" - pattern -type string -optional 1 -default * -multiple 1 -help\ - "glob-style patterns for retrieving value or switch - definitions. - - If -type is * and pattern is * the entire definition including - directive lines will be returned in line form. - (directives are lines beginning with - @ e.g @id, @cmd etc) - - if -type is leaders,opts or values matches from that type - will be returned. - - if -type is another directive such as @id, @doc etc the - patterns are ignored. - - " - }]] - } - - - proc resolved_def {args} { - #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. - set opts [dict create\ - -return text\ - -types {}\ - -form 0\ - -antiglobs {}\ - -override {}\ - ] - if {[llength $args] < 1} { - #must have at least id - punk::args::parse $args withid ::punk::args::resolved_def - return - } - set patterns [list] - - #a definition id must not begin with "-" ??? review - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {$a in {-type -types}} { - incr i - dict set opts -types [lindex $args $i] - } elseif {[string match -* $a]} { - incr i - dict set opts $a [lindex $args $i] - } else { - set id [lindex $args $i] - set patterns [lrange $args $i+1 end] - break - } - if {$i == [llength $args]-1} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - if {![llength $patterns]} { - set patterns [list *] - } - dict for {k v} $opts { - switch -- $k { - -return - -form - -types - -antiglobs - -override {} - default { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - } - set typelist [dict get $opts -types] - if {[llength $typelist] == 0} { - set typelist {*} - } - foreach type $typelist { - if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - - - variable id_cache_rawdef - set realid [real_id $id] - if {$realid eq ""} { - return - } - - set deflist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] - - set opt_form [dict get $opts -form] - if {[string is integer -strict $opt_form]} { - set formname [lindex [dict get $specdict form_names] $opt_form] - } else { - set formname $opt_form - } - set opt_override [dict get $opts -override] - set opt_return [dict get $opts -return] - - #set arg_info [dict get $specdict ARG_INFO] - set arg_info [dict get $specdict FORMS $formname ARG_INFO] - set argtypes [dict create leaders leader opts option values value] - - set opt_antiglobs [dict get $opts -antiglobs] - set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] - set suppressed_directives [list] - set suppressed_args [list] - foreach ag $opt_antiglobs { - foreach d $directives { - if {[string match $ag $d]} { - lappend suppressed_directives $d - } - } - foreach argname [dict keys $arg_info] { - if {[string match $ag $argname]} { - lappend suppressed_args $argname - } - } - } - set suppressed_directives [lsort -unique $suppressed_directives] - set suppressed_args [lsort -unique $suppressed_args] - - set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] - - set globbed [list] - foreach pat $patterns { - set matches [dict keys $arg_info $pat] - lappend globbed {*}$matches - } - set globbed [lsort -unique $globbed] - set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args] - - set result "" - set resultdict [dict create] - foreach type $typelist { - switch -exact -- $type { - * { - if {"@id" in $included_directives} { - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - foreach directive {@package @cmd @doc @seealso @argdisplay} { - set dshort [string range $directive 1 end] - if {"$directive" in $included_directives} { - if {[dict exists $opt_override $directive]} { - append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict ${dshort}_info]" - dict set resultdict $directive [dict get $specdict ${dshort}_info] - } - } - } - #output ordered by leader, option, value - foreach pseudodirective {leaders opts values} tp {leader option value} { - set directive "@$pseudodirective" - switch -- $directive { - @leaders {set defaults_key leaderspec_defaults} - @opts {set defaults_key optspec_defaults} - @values {set defaults_key valspec_defaults} - } - - if {"$directive" in $included_directives} { - if {[dict exists $opt_override "$directive"]} { - append result \n "$directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict $defaults_key]" - dict set resultdict $directive [dict get $specdict $defaults_key] - } - } - - if {$pseudodirective in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq $tp} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "$m $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - - } - @id { - if {"@id" in $included_directives} { - #only a single id record can exist - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - } - @package - @cmd - @doc - @seealso - @argdisplay { - if {"$type" in $included_directives} { - set tp [string range $type 1 end] ;# @package -> package - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict ${tp}_info]" - dict set resultdict $type [dict get $specdict ${tp}_info] - } - } - } - @leaders - @opts - @values { - #these are the active defaults for further arguments - if {"$type" in $included_directives} { - switch -- $type { - @leaders {set defaults_key leaderspec_defaults} - @opts {set defaults_key optspec_defaults} - @values {set defaults_key valspec_defaults} - } - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict leaderspec_defaults]" - dict set resultdict $type [dict get $specdict leaderspec_defaults] - } - } - } - leaders - opts - values { - #pseudo-directives - if {$type in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "$m $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - default { - } - } - if {$opt_return eq "text"} { - return $result - } else { - return $resultdict - } - } - } - - proc resolved_def_values {id {patternlist *}} { - variable id_cache_rawdef - set realid [real_id $id] - if {$realid ne ""} { - set speclist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [resolve {*}$speclist] - set arg_info [dict get $specdict ARG_INFO] - set valnames [dict get $specdict VAL_NAMES] - set result "" - if {$patternlist eq "*"} { - foreach v $valnames { - set def [dict get $arg_info $v] - set def [dict remove $def -ARGTYPE] - append result \n "$v $def" - } - return $result - } else { - foreach pat $patternlist { - set matches [dict keys $arg_info $pat] - set matches [lsearch -all -inline -glob $valnames $pat] - foreach m $matches { - set def [dict get $arg_info $m] - set def [dict remove $def -ARGTYPE] - append result \n "$m $def" - } - } - return $result - } - } - } - #proc resolved_def_leaders ?? - #proc resolved_def_opts ?? - - proc get_spec {id} { - set rdef [raw_def $id] - if {$rdef eq ""} {return} - return [resolve {*}$rdef] - #if {[id_exists $id]} { - # return [resolve {*}[raw_def $id]] - #} - } - proc is_dynamic {id} { - variable id_cache_rawdef - variable rawdef_cache - set deflist [raw_def $id] - if {[dict exists $rawdef_cache $deflist -dynamic]} { - return [dict get $rawdef_cache $deflist -dynamic] - } - return [rawdef_is_dynamic $deflist] - #@dynamic only has meaning as 1st element of a def in the deflist - } - - #@id must be within first 4 lines of a block - or assign auto - #review - @dynamic block where -id not explicitly set? - disallow? - proc rawdef_id {rawdef} { - set id "" - foreach d $rawdef { - foreach ln [lrange [split $d \n] 0 4] { - if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { - if {$firstword eq "@id"} { - if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { - set id [dict get $rest -id] - break - } - } - } - } - if {$id ne ""} { - break - } - } - if {$id eq "" || [string tolower $id] eq "auto"} { - variable id_counter - set id "autoid_[incr id_counter]" - } - #puts "==>id: $id" - return $id - } - #test the rawdef for @dynamic directive - proc rawdef_is_dynamic {rawdef} { - #temporary - old way - set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] - if {$flagged_dynamic} { - return true - } - foreach d $rawdef { - if {[regexp {\s*(\S+)} $d _match firstword]} { - if {$firstword eq "@dynamic"} { - return true - } - } - } - return false - } - - variable aliases - set aliases [dict create] - - lappend PUNKARGS [list { - @id -id ::punk::args::get_ids - @cmd -name punk::args::get_ids -help\ - "return list of ids for argument definitions" - @values -min 0 -max 1 - match -default * -help\ - "exact id or glob pattern for ids" - }] - proc get_ids {{match *}} { - variable id_cache_rawdef - variable aliases - return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] - } - - #we don't automatically test for (autodef)$id - only direct ids and aliases - proc id_exists {id} { - variable aliases - if {[tcl::dict::exists $aliases $id]} { - return 1 - } - variable id_cache_rawdef - tcl::dict::exists $id_cache_rawdef $id - } - proc set_alias {alias id} { - variable aliases - dict set aliases $alias $id - } - proc unset_alias {alias} { - variable aliases - dict unset aliases $alias - } - proc get_alias {alias} { - variable aliases - if {[dict exists $aliases $alias]} { - return [tcl::dict::get $aliases $alias] - } - } - - proc real_id {id} { - variable id_cache_rawdef - variable aliases - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } else { - set check_updates [list [namespace qualifiers $id]] - if {![llength [update_definitions $check_updates]]} { - #nothing new loaded - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } else { - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } - } - } - - proc status {} { - upvar ::punk::args::register::NAMESPACES registered - upvar ::punk::args::register::loaded_packages loaded_packages - upvar ::punk::args::register::loaded_info loaded_info - upvar ::punk::args::register::scanned_packages scanned_packages - upvar ::punk::args::register::scanned_info scanned_info - set result "" - # [format %-${w0}s $idtail] - set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] - append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n - set width_c2 [string length "Scanned_ids"] - set width_c3 [string length "Scantime_us"] - set width_c4 [string length "Loaded_defs"] - set width_c5 [string length "Loadtime_us"] - set count_unloaded 0 - set count_loaded 0 - foreach ns $registered { - if {$ns in $scanned_packages} { - set ids [dict get $scanned_info $ns idcount] - set scan_us [dict get $scanned_info $ns time] - } else { - set ids "" - set scan_us "" - } - if {$ns in $loaded_packages} { - incr count_loaded - set ldefs [dict get $loaded_info $ns defcount] - set load_us [dict get $loaded_info $ns time] - } else { - incr count_unloaded - set ldefs "" - set load_us "" - } - append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n - } - append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" - return $result - } - - #scanned_packages (list) - #namespace_docpackages (dict) - proc update_definitions {{nslist *}} { - if {[set gposn [lsearch $nslist {}]] >= 0} { - lset nslist $gposn :: - } - upvar ::punk::args::register::NAMESPACES registered ;#list - upvar ::punk::args::register::loaded_packages loaded_packages ;#list - upvar ::punk::args::register::loaded_info loaded_info ;#dict - upvar ::punk::args::register::scanned_packages scanned_packages ;#list - upvar ::punk::args::register::scanned_info scanned_info ;#dict - upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict - - - #puts stderr "-->update_definitions '$nslist'" - #needs to run quickly - especially when no package namespaces to be scanned for argdefs - #e.g - gets called for each subcommand of an ensemble (could be many) - # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. - #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. - # -- --- --- --- --- --- - # common-case fast-path - - if {[llength $loaded_packages] == [llength $registered]} { - #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. - #assert - if all are registered - then all have been scanned ( - return {} - } - # -- --- --- --- --- --- - - set unscanned [punklib_ldiff $registered $scanned_packages] - if {[llength $unscanned]} { - foreach pkgns $unscanned { - set idcount 0 - set ts_start [clock microseconds] - if {[info exists ${pkgns}::PUNKARGS]} { - set seen_documentedns [list] ;#seen per pkgns - foreach definitionlist [set ${pkgns}::PUNKARGS] { - #namespace eval $evalns [list punk::args::define {*}$definitionlist] - set id [rawdef_id $definitionlist] - if {[string match autoid_* $id]} { - puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" - puts stderr "definition:\n" - foreach d $definitionlist { - set out "" - foreach ln [split $d \n] { - append out " " $ln \n - } - puts $out - } - continue - } - #todo - detect duplicate ids (last will silently win.. should be reported somewhere) - incr idcount - set documentedns [namespace qualifiers $id] - if {$documentedns eq ""} {set documentedns ::} - if {$documentedns ni $seen_documentedns} { - #don't add own ns as a key in namespace_docpackages - if {$documentedns ne $pkgns} { - dict lappend namespace_docpackages $documentedns $pkgns - } - lappend seen_documentedns $documentedns - } - } - } - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - dict set scanned_info $pkgns [dict create time $diff idcount $idcount] - #we count it as scanned even if PUNKARGS didn't exist - #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) - lappend scanned_packages $pkgns - } - } - - - - if {"*" in $nslist} { - set needed [punklib_ldiff $registered $loaded_packages] - } else { - set needed [list] - foreach pkgns $nslist { - if {$pkgns in $registered && $pkgns ni $loaded_packages} { - lappend needed $pkgns - } - #argdoc sub namespace is a standard place to put defs that match the namespace below - #(generally the PUNKARGS in a namespace should apply to own ns) - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { - lappend needed $docns - } - } - if {[dict exists $namespace_docpackages $pkgns]} { - #this namespace has other argdef sources - foreach docns [dict get $namespace_docpackages $pkgns] { - if {$docns ni $loaded_packages} { - lappend needed $docns - } - } - } - } - } - - - - set newloaded [list] - foreach pkgns $needed { - #puts stderr "update_definitions Loading: $pkgns" - set ts_start [clock microseconds] - set def_count 0 - if {![catch { - if {[info exists ${pkgns}::PUNKARGS]} { - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - namespace eval ${pkgns}::argdoc { - set epath [namespace path] - set pkgns [namespace parent] - if {$pkgns ni $epath} { - namespace path [list {*}$epath $pkgns] ;#add to tail - } - - } - set evalns $docns - } else { - set evalns $pkgns - } - foreach definitionlist [set ${pkgns}::PUNKARGS] { - namespace eval $evalns [list punk::args::define {*}$definitionlist] - incr def_count - } - } - - #process list of 2-element lists - if {[info exists ${pkgns}::PUNKARGS_aliases]} { - foreach adef [set ${pkgns}::PUNKARGS_aliases] { - punk::args::set_alias {*}$adef - } - } - } errMsg]} { - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - lappend loaded_packages $pkgns - lappend newloaded $pkgns - dict set loaded_info $pkgns [dict create time $diff defcount $def_count] - } else { - puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" - } - } - return $newloaded - } - - #for use within get_dict only - #This mechanism gets less-than-useful results for oo methods - #e.g {$obj} - proc Get_caller {} { - #set call_level -3 ;#for get_dict call - set call_level -4 - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - #puts "-->$cmdinfo" - #puts "-->[tcl::info::frame -3]" - while {[string last \n $cmdinfo] >= 1} { - #looks like a script - haven't gone up far enough? - #(e.g patternpunk oo system: >punk . poses -invalidoption) - incr call_level -1 - if {[catch { - set nextup [tcl::info::frame $call_level] - } ]} { - break - } - set cmdinfo [tcl::dict::get $nextup cmd] - set caller [regexp -inline {\S+} $cmdinfo] - if {[interp alias {} $caller] ne ""} { - #puts "found alias for caller $caller to [interp alias {} $caller]" - #see if we can go further - incr call_level -1 - if {[catch { - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - } errM ]} { - puts "err: $errM" - break - } - } - } - set caller [regexp -inline {\S+} $cmdinfo] - if {$caller eq "namespace"} { - # review - message? - set cmdinfo "punk::args::get_dict called from namespace" - } - return $cmdinfo - } - - - # -------------------------------------- - #test of Get_caller - lappend PUNKARGS [list { - @id -id ::punk::args::test1 - @values -min 0 -max 0 - }] - proc test_get_dict {args} { - punk::args::get_dict {*}[punk::args::raw_def ::punk::args::test1] $args - } - proc test_get_by_id {args} { - punk::args::get_by_id ::punk::args::test1 $args - } - #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. - proc test_callers {args} { - if {![llength $args]} { - puts "these test functions accept no arguments" - puts "Call with arg(s) to compare error output" - } - - if {[catch {test_get_dict {*}$args} errM]} { - puts $errM - } - puts "------------" - if {[catch {test_get_by_id {*}$args} errM]} { - puts $errM - } - return done - } - # -------------------------------------- - - set map "" - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::arg_error - @cmd -name punk::args::arg_error -help\ - "Generates a table (by default) of usage information for a command. - A trie system is used to create highlighted prefixes for command - switches and for subcommands or argument/switch values that accept - a defined set of choices. These prefixes match the mechanism used - to validate arguments (based on tcl::prefix::match). - - This function is called during the argument parsing process - (if the definition is not only being used for documentation) - It is also called by punk::args::usage which is in turn - called by the punk::ns introspection facilities which creates - on the fly definitions for some commands such as ensembles and - oo objects where a manually defined one isn't present. - " - @leaders -min 2 -max 2 - msg -type string -help\ - "Error message to display immediately prior to usage table. - May be empty string to just display usage. - " - spec_dict -type dict -help\ - "Dictionary of argument specifications. - This is the internal format parsed from - the textual definition. It contains the data - organised/optimised to allow the final arg - parser/validator to make decisions. - " - @opts - -badarg -type string -help\ - "name of an argument to highlight" - -aserror -type boolean -help\ - "If true, the usage table is raised as an error message, - otherwise it is returned as a value." - -return -choices {string table tableobject} -choicelabels { - string "no table layout" - tableobject "table object cmd" - table "full table laout" - } - -scheme -choices {nocolour info error} - }] ] - - #basic recursion blocker - variable arg_error_isrunning 0 - proc arg_error {msg spec_dict args} { - #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. - #accept an option here so that we can still use full output for usage requests. - #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args - #Development/experimentation may be done with full table-based error reporting - but for production release it - #may be desirable to reduce overhead on catches. - #consider per-namespace or namespace-tree configurability. - #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due - #to resource availability etc - so the slower error generation time may not always be a problem. - #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling - #code which has no use for the enhanced error info. - #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. - #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system - #todo - #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error - #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) - - #todo - document unnamed leaders and unnamed values where -min and/or -max specified - #e.g punk::args::get_dict {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} {} - #only |?-x?|string|... is shown in the output table. - #should be something like: - # |arg | - # |?-x? | - # |arg | - # |?arg...?| - # Where/how to specify counts? - #also.. - # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? - # - - - if {[catch {package require punk::ansi}]} { - proc punk::args::a {args} {} - proc punk::args::a+ {args} {} - } else { - namespace eval ::punk::args { - namespace import ::punk::ansi::a ::punk::ansi::a+ - } - } - #limit colours to standard 16 so that themes can apply to help output - variable arg_error_isrunning - if {$arg_error_isrunning} { - error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" - } - - if {[llength $args] %2 != 0} { - error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" - } - - set arg_error_isrunning 1 - - set badarg "" - set returntype table ;#table as string - set as_error 1 ;#usual case is to raise an error - set scheme error - dict for {k v} $args { - set fullk [tcl::prefix::match -error "" {-badarg -aserror -return -scheme} $k] - switch -- $fullk { - -badarg { - set badarg $v - } - -aserror { - if {![string is boolean -strict $v]} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" - } - set as_error $v - } - -scheme { - set scheme $v - } - -return { - if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" - } - set returntype $v - } - default { - set arg_error_isrunning 0 - error "arg_error invalid option $k. Known_options: -badarg -return -aserror" - } - } - } - #todo - scheme - use config and iterm toml definitions etc - switch -- $scheme { - "" - -nocolor - -nocolour { - set scheme nocolour - } - info - error {} - default { - set scheme na - } - } - #hack some basics for now. - #for coloured schemes - use bold as well as brightcolour in case colour off. - array set CLR {} - set CLR(errormsg) [a+ brightred] - set CLR(title) "" - set CLR(check) [a+ brightgreen] - set CLR(solo) [a+ brightcyan] - set CLR(choiceprefix) [a+ underline] - set CLR(badarg) [a+ brightred] - set CLR(linebase_header) [a+ white] - set CLR(cmdname) [a+ brightwhite] - set CLR(groupname) [a+ bold] - set CLR(ansiborder) [a+ bold] - set CLR(ansibase_header) [a+ bold] - set CLR(ansibase_body) [a+ white] - - switch -- $scheme { - nocolour { - set CLR(errormsg) [a+ bold] - set CLR(title) [a+ bold] - set CLR(check) "" - set CLR(solo) "" - set CLR(badarg) [a+ reverse] ;#? experiment - set CLR(cmdname) [a+ bold] - set CLR(linebase_header) "" - set CLR(linebase) "" - set CLR(ansibase_body) "" - } - info { - set CLR(errormsg) [a+ brightred bold] - set CLR(title) [a+ brightyellow bold] - set CLR(check) [a+ brightgreen bold] - set CLR(choiceprefix) [a+ brightgreen bold] - set CLR(groupname) [a+ cyan bold] - set CLR(ansiborder) [a+ brightcyan bold] - set CLR(ansibase_header) [a+ cyan] - set CLR(ansibase_body) [a+ white] - } - error { - set CLR(errormsg) [a+ brightred bold] - set CLR(title) [a+ brightcyan bold] - set CLR(check) [a+ brightgreen bold] - set CLR(choiceprefix) [a+ brightgreen bold] - set CLR(groupname) [a+ cyan bold] - set CLR(ansiborder) [a+ brightyellow bold] - set CLR(ansibase_header) [a+ yellow] - set CLR(ansibase_body) [a+ white] - } - na { - } - } - - - #set RST [a] - set RST "\x1b\[m" - set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. - - #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error - #e.g list_as_table - - # use basic colours here to support terminals without extended colours - #todo - add checks column (e.g -minsize -maxsize) - set errmsg $msg - if {![catch {package require textblock}]} { - set has_textblock 1 - } else { - set has_textblock 0 - #couldn't load textblock package - #just return the original errmsg without formatting - } - set use_table 0 - if {$has_textblock && $returntype in {table tableobject}} { - set use_table 1 - } - set errlines [list] ;#for non-textblock output - if {[catch { - if {$use_table} { - append errmsg \n - } else { - if {($returntype in {table tableobject}) && !$has_textblock} { - append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n - } else { - append errmsg \n - } - } - set cmdname [Dict_getdef $spec_dict cmd_info -name ""] - set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] - - set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] - set docurl [Dict_getdef $spec_dict doc_info -url ""] - - set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] - set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] - if {"$argdisplay_header$argdisplay_body" eq ""} { - set is_custom_argdisplay 0 - } else { - set is_custom_argdisplay 1 - } - - - set blank_header_col [list] - if {$cmdname ne ""} { - lappend blank_header_col "" - set cmdname_display $CLR(cmdname)$cmdname$RST - } else { - set cmdname_display "" - } - if {$cmdhelp ne ""} { - lappend blank_header_col "" - #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] - set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] - } else { - set cmdhelp_display "" - } - if {$docurl ne ""} { - lappend blank_header_col "" - set docurl_display [a+ white]$docurl$RST - } else { - set docurl_display "" - } - #synopsis - set synopsis "" - set form_info [dict get $spec_dict FORM_INFO] - dict for {fid finfo} $form_info { - set syn [Dict_getdef $finfo -synopsis ""] - if {$syn ne ""} { - append synopsis $syn \n - } - } - if {$synopsis ne ""} { - set synopsis [string range $synopsis 0 end-1] - lappend blank_header_col "" - } - - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - if {$use_table} { - set t [textblock::class::table new "$CLR(title)Usage$RST"] - $t add_column -headers $blank_header_col -minwidth 3 - $t add_column -headers $blank_header_col - - if {!$is_custom_argdisplay} { - lappend blank_header_col "" - #spanned columns in default argdisplay area - $t add_column -headers $blank_header_col ;#Default - $t add_column -headers $blank_header_col ;#Multi - $t add_column -headers $blank_header_col ;#Help - set arg_colspans {1 4 0 0 0} - } else { - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - set arg_colspans {1 1} - } - } - set h 0 - if {$cmdname ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] - } else { - lappend errlines "COMMAND: $cmdname_display" - } - incr h - } - if {$cmdhelp ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] - } else { - lappend errlines "Description: $cmdhelp_display" - } - incr h - } - if {$docurl ne ""} { - if {![catch {package require punk::ansi}]} { - set docurl [punk::ansi::hyperlink $docurl] - } - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] - } else { - lappend errlines "$docname $docurl_display" - } - incr h - } - if {$synopsis ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Synopsis: $synopsis] - } else { - #todo - lappend errlines "Synopsis:\n$synopsis" - } - incr h - } - - - if {$use_table} { - if {$is_custom_argdisplay} { - if {$argdisplay_header ne ""} { - $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] - } - } else { - $t configure_header $h -values {Arg Type Default Multi Help} - } - } else { - lappend errlines " --ARGUMENTS-- " - } - - if {$is_custom_argdisplay} { - if {$use_table} { - #using overall container table - #header already added - #TODO - review textblock::table features - #we can't currently span columns within the table body. - #This feature could allow hidden data columns (and sort on hidden col?) - #potentially require coordination with header colspans? - $t add_row [list "" $argdisplay_body] - } else { - if {$argdisplay_header ne ""} { - lappend errlines $argdisplay_header - } - lappend errlines {*}$argdisplay_body - } - } else { - - #set A_DEFAULT [a+ brightwhite Brightgreen] - set A_DEFAULT "" - set A_BADARG $CLR(badarg) - set greencheck $CLR(check)\u2713$RST ;#green tick - set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply - if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { - #A_PREFIX can resolve to empty string if colour off - #we then want to display underline instead - set A_PREFIX [a+ underline] - set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space - } else { - set A_PREFIXEND $RST - } - - set opt_names [list] - set opt_names_display [list] - if {[llength [dict get $spec_dict OPT_NAMES]]} { - if {![catch {package require punk::trie}]} { - set trie [punk::trie::trieclass new {*}[dict get $spec_dict OPT_NAMES]] - set idents [dict get [$trie shortest_idents ""] scanned] - #todo - check opt_prefixdeny - - $trie destroy - foreach c [dict get $spec_dict OPT_NAMES] { - set id [dict get $idents $c] - #REVIEW - if {$id eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $id] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail - #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] - lappend opt_names $c - } - } else { - set opt_names [dict get $spec_dict OPT_NAMES] - set opt_names_display $opt_names - } - } - set leading_val_names [dict get $spec_dict LEADER_NAMES] - set trailing_val_names [dict get $spec_dict VAL_NAMES] - - #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { - # if {![string match -* $argname]} { - # lappend leading_val_names [lpop trailing_val_names 0] - # } else { - # break - # } - #} - #if {![llength $leading_val_names] && ![llength $opt_names]} { - # #all vals were actually trailing - no opts - # set trailing_val_names $leading_val_names - # set leading_val_names {} - #} - set leading_val_names_display $leading_val_names - set trailing_val_names_display $trailing_val_names - - #display options first then values - foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { - lassign $argumentset argnames_display argnames - - foreach argshow $argnames_display arg $argnames { - set arginfo [dict get $spec_dict ARG_INFO $arg] - if {[dict exists $arginfo -default]} { - set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" - } else { - set default "" - } - set help [Dict_getdef $arginfo -help ""] - set allchoices_originalcase [list] - set choices [Dict_getdef $arginfo -choices {}] - set choicegroups [Dict_getdef $arginfo -choicegroups {}] - set choicemultiple [dict get $arginfo -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] - set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] - if {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - set is_multiple 1 - } else { - set multiple "" - set is_multiple 0 - } - if {[dict exists $choicegroups ""]} { - dict lappend choicegroups "" {*}$choices - } else { - set choicegroups [dict merge [dict create "" $choices] $choicegroups] - } - dict for {groupname clist} $choicegroups { - lappend allchoices_originalcase {*}$clist - } - set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] - - if {$has_choices} { - if {$help ne ""} {append help \n} - if {[dict get $arginfo -nocase]} { - set casemsg " (case insensitive)" - set allchoices_test [string tolower $allchoices_originalcase] - } else { - set casemsg " (case sensitive)" - set allchoices_test $allchoices_originalcase - } - if {[dict get $arginfo -choiceprefix]} { - set prefixmsg " (choice prefix allowed)" - } else { - set prefixmsg "" - } - set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] - set formattedchoices [dict create] ;#use dict rather than array to preserve order - append help " Choices$prefixmsg$casemsg" - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - if {$choicemultiple_max == -1} { - append help \n " The value can be a list of $choicemultiple_min or more of these choices" - } else { - if {$choicemultiple_min eq $choicemultiple_max} { - append help \n " The value must be a list of $choicemultiple_min of these choices" - } else { - append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" - } - } - } - if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set cdisplay $c - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - dict lappend formattedchoices $groupname $cdisplay - } - } - } else { - set formattedchoices $choicegroups - #set formattedchoices [dict get $arginfo -choices] - } - } else { - if {[catch { - set trie [punk::trie::trieclass new {*}$allchoices_test] - set idents [dict get [$trie shortest_idents ""] scanned] - if {[dict get $arginfo -nocase]} { - #idents were calculated on lcase - remap keys in idents to original casing - set actual_idents $idents - foreach ch $allchoices_originalcase { - if {![dict exists $idents $ch]} { - #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting - #The actual testing is done in get_dict - dict set actual_idents $ch [dict get $idents [string tolower $ch]] - } - } - set idents $actual_idents - #puts "-----" - #puts "idents $idents" - } - - $trie destroy - dict for {groupname clist} $choicegroups { - foreach c $clist { - if {$c in $choiceprefixdenylist} { - set shortestid $c - } else { - set shortestid [dict get $idents $c] - } - if {$shortestid eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $shortestid] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]" - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - dict lappend formattedchoices $groupname $cdisplay - } - } - } errM]} { - #this failure can happen if -nocase is true and there are ambiguous entries - #e.g -nocase 1 -choices {x X} - puts stderr "prefix marking failed\n$errM" - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set cdisplay $c - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - dict lappend formattedchoices $groupname $cdisplay - } - } - } else { - set formattedchoices $choicegroups - } - - } - } - set choicetable_objects [list] - set choicetable_footers [dict create] - dict for {groupname formatted} $formattedchoices { - set numcols $choicecolumns ;#todo - dynamic? - if {[llength $formatted] < $numcols} { - #don't show blank cells if single line of results - set numcols [llength $formatted] - } - if {$numcols > 0} { - if {$use_table} { - #risk of recursing - #TODO -title directly in list_as_table - set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] - lappend choicetable_objects $choicetableobj - $choicetableobj configure -title $CLR(groupname)$groupname - #append help \n[textblock::join -- " " [$choicetableobj print]] - } else { - if {$groupname ne ""} { - append help \n \n "$CLR(groupname)Group: $groupname$RST" - } else { - append help \n - } - append help \n [join $formatted \n] - } - } else { - #we were given an empty set of choices. - #probably an error in the definition - but could happen if dynamically generated. - #(e.g ensemble where unknown mechanism is used for subcommands?) - #better to just display that there were none rather than totally break the usage output. - if {$usetable} { - #these will be displayed after all table entries - if {$groupname eq ""} { - dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" - } else { - dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" - } - } else { - if {$groupname eq ""} { - append help \n " " $CLR(errormsg)(no choices defined)$RST - } else { - append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST - } - } - } - } - set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width - foreach obj $choicetable_objects { - dict lappend twidths_by_colcount [$obj column_count] [$obj width] - } - foreach obj $choicetable_objects { - set cols [$obj column_count] - set widths [dict get $twidths_by_colcount $cols] - set max [tcl::mathfunc::max {*}$widths] - $obj configure -minwidth $max ;#expand smaller ones - set i 0 - while {$i < $cols} { - #keep text aligned left on expanded tables - $obj configure_column $i -blockalign left - incr i - } - - append help \n[textblock::join -- " " [$obj print]] - #set ansititle [dict get [$obj configure -title] value] - $obj destroy - } - if {[dict size $choicetable_footers]} { - foreach groupname [dict keys $formattedchoices] { - if {[dict exists $choicetable_footers $groupname]} { - append help \n [dict get $choicetable_footers $groupname] - } - } - } - - #review. use -type to restrict additional choices - may be different to values in the -choices - if {![dict get $arginfo -choicerestricted]} { - #when -choicemultiple - the -type refers to each selection - if {[dict get $arginfo -type] eq "string"} { - append help "\n (values not in defined choices are allowed)" - } else { - append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" - } - } - } - if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { - if {$is_multiple} { - set argshow "?${argshow}...?" - } else { - set argshow "?${argshow}?" - } - } else { - if {$is_multiple} { - set argshow "${argshow}..." - } - } - set typeshow [dict get $arginfo -type] - if {$typeshow eq "none"} { - set typeshow "$typeshow $soloflag" - } - if {[dict exists $arginfo -minsize]} { - append typeshow \n "-minsize [dict get $arginfo -minsize]" - } - if {[dict exists $arginfo -maxsize]} { - append typeshow \n "-maxsize [dict get $arginfo -maxsize]" - } - if {[dict exists $arginfo -range]} { - append typeshow \n "-range [dict get $arginfo -range]" - } - - if {$use_table} { - $t add_row [list $argshow $typeshow $default $multiple $help] - if {$arg eq $badarg} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG - } - } else { - #review - formatting will be all over the shop due to newlines in typesshow, help - set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" - foreach ln [split $help \n] { - append arghelp " $ln" \n - } - lappend errlines $arghelp - } - } - } - } ;#end is_custom_argdisplay - - if {$use_table} { - $t configure -show_hseps 0\ - -show_header 1\ - -ansibase_body $CLR(ansibase_body)\ - -ansibase_header $CLR(ansibase_header)\ - -ansiborder_header $CLR(ansiborder)\ - -ansiborder_body $CLR(ansiborder) - - $t configure -maxwidth 80 ;#review - if {$returntype ne "tableobject"} { - append errmsg [$t print] - #returntype of table means just the text of the table - $t destroy - } - } else { - append errmsg [join $errlines \n] - } - } errM]} { - catch {$t destroy} - append errmsg \n - append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n - append errmsg "$errM" \n - append errmsg "$::errorInfo" - - } - set arg_error_isrunning 0 - #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. - #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) - if {$use_table} { - #assert returntype is one of table, tableobject - set result $errmsg ;#default if for some reason table couldn't be used - if {$returntype eq "tableobject"} { - if {[info object isa object $t]} { - set result $t - } - } - } else { - set result $errmsg - } - if {$as_error} { - return -code error -errorcode {TCL WRONGARGS PUNK} $result - } else { - return $result - } - } - - - lappend PUNKARGS [list { - @dynamic - @id -id ::punk::args::usage - @cmd -name punk::args::usage -help\ - "Return usage information for a command identified by an id. - - This will only work for commands where a punk::args definition exists - for the command and an id has been defined for it. The id for custom - help for a command should match the fully qualified name of the command. - - Many commands (such as ensembles and oo objects) may have argument - documentation generated dynamically and may not yet have an id. - IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. - - Generally punk::ns::arginfo (aliased as i in the punk shell) should - be used in preference - as it will search for a documentation - mechanism and call punk::args::usage as necessary. - " - -return -default table -choices {string table tableobject} - } {${[punk::args::resolved_def -types opts ::punk::args::arg_error -scheme]}} { - - @values -min 0 -max 1 - id -help\ - "Exact id. - Will usually match the command name" - }] - proc usage {args} { - lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received - set id [dict get $values id] - set real_id [real_id $id] - if {$real_id eq ""} { - error "punk::args::usage - no such id: $id" - } - arg_error "" [punk::args::get_spec $real_id] -scheme punk_info {*}$opts -aserror 0 - } - - lappend PUNKARGS [list { - @id -id ::punk::args::get_by_id - @cmd -name punk::args::get_by_id - @values -min 1 - id - arglist -type list -help\ - "list containing arguments to be parsed as per the - argument specification identified by the supplied id." - }] - - - #deprecate? - proc get_by_id {id arglist} { - set definitionlist [punk::args::raw_def $id] - if {[llength $definitionlist] == 0} { - error "punk::args::get_by_id - no such id: $id" - } - #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] - tailcall ::punk::args::get_dict {*}$definitionlist $arglist - } - - #consider - - #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) - #parse ?-flag val?... -- $arglist withid $id - #parse ?-flag val?... -- $arglist withdef $def ?$def?... - - #an experiment.. ideally we'd like arglist at the end? - #parse_withid ?-flag val?.. $id $arglist - #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? - #no possible equivalent for parse_withdef ??? - - lappend PUNKARGS [list { - @id -id ::punk::args::parse - @cmd -name punk::args::parse -help\ - "parse and validate command arguments based on a definition. - - In the 'withid' form the definition is a pre-existing record that has been - created with ::punk::args::define, or indirectly by adding a definition to - the PUNKARGS variable in a namespace which is then registered in - punk::args::register::NAMESPACES, or by a previous call to punk::parse - using 'withdef' and a definition block containing an @id -id directive. - - In the 'withdef' form - the definition is created on the first call and - cached thereafter, if the id didn't already exist. - - form1: parse $arglist ?-flag val?... withid $id - form2: parse $arglist ?-flag val?... withdef $def ?$def? - see punk::args::define" - @form -form {withid withdef} - @leaders -min 1 -max 1 - arglist -type list -optional 0 -help\ - "Arguments to parse - supplied as a single list" - - @opts - -form -type list -default * -help\ - "Restrict parsing to the set of forms listed. - Forms are the orthogonal sets of arguments a - command can take - usually described in 'synopsis' - entries." - #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance - #todo - configurable per interp/namespace - -errorstyle -type string -default enhanced -choices {enhanced standard minimal} - - @values -min 2 - - @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" - withid -type literal -help\ - "The literal value 'withid'" - id -type string -help\ - "id of punk::args definition for a command" - - - @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" - withdef -type literal -help\ - "The literal value 'withdef'" - - #todo - make -dynamic obsolete - use @dynamic directive instead - def -type string -multiple 1 -optional 0 -help\ - "Each remaining argument is a block of text - defining argument definitions. - As a special case, -dynamic may be - specified as the 1st 2 arguments. These are - treated as an indicator to punk::args about - how to process the definition." - - }] - proc parse {args} { - set tailtype "" ;#withid|withdef - if {[llength $args] < 3} { - error "punk::args::parse - invalid call. < 3 args" - } - set parseargs [lindex $args 0] - set tailargs [lrange $args 1 end] - - set split [lsearch -exact $tailargs withid] - if {$split < 0} { - set split [lsearch -exact $tailargs withdef] - if {$split < 0} { - #punk::args::usage arg_error? - error "punk::args::parse - invalid call. keyword withid|withdef required" - } else { - set tailtype withdef - } - } else { - set tailtype withid - } - - set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. - if {[llength $opts] % 2} { - error "punk::args::parse Even number of -flag val pairs required after arglist" - } - set defaultopts [dict create\ - -form {*}\ - -errorstyle enhanced\ - ] - set opts [dict merge $opts $defaultopts] - dict for {k v} $opts { - switch -- $k { - -form - -errorstyle { - } - default { - #punk::args::usage $args withid ::punk::args::parse ?? - error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" - } - } - } - switch -- $tailtype { - withid { - if {[llength [lrange $tailargs $split+1 end]] != 1} { - error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - } - set id [lindex $tailargs $split+1] - #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" - set deflist [raw_def $id] - if {[llength $deflist] == 0} { - error "punk::args::parse - no such id: $id" - } - } - withdef { - set deflist [lrange $tailargs $split+1 end] - if {[llength $deflist] < 1} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" - } - default { - error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" - } - } - try { - set result [punk::args::get_dict {*}$deflist $parseargs] - } trap {PUNKARGS} {msg opts} { - #trap punk::args argument validation/parsing errors and decide here - #whether to display basic error - or full usage if configured. - puts stderr "PUNKARGS: $msg\n$opts" - return - } trap {} {msg opts} { - #review - #puts stderr "$msg\n$opts" - #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. - #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. - throw [dict get $opts -errorcode] [dict get $opts -errorinfo] - return - } - return $result - } - proc parseXXX {args} { - #no solo flags allowed for parse function itself. (ok for arglist being parsed) - set opts [dict create] ;#repeated flags will override earlier. That's ok here. - set arglist {} - set got_arglist 0 - set tailtype "" ;#withid|withdef - set id "" - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {[string match -* $a]} { - dict set opts $a [lindex $args $i+1] - incr i - } else { - set arglist $a - set got_arglist 1 - set tailtype [lindex $args $i+1] - if {$tailtype eq "withid"} { - if {[llength $args] != $i+3} { - error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - } - set id [lindex $args $i+2] - break - } elseif {$tailtype eq "withdef"} { - if {[llength $args] < $i+3} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - set deflist [lrange $args $i+2 end] - break - } else { - error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" - } - } - } - if {!$got_arglist} { - error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." - } - #assert tailtype eq withid|withdef - if {$tailtype eq "withid"} { - #assert $id was provided - return "parse [llength $arglist] args withid $id, options:$opts" - } else { - #assert llength deflist >=1 - return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" - } - #TODO - } - - #todo? - a version of get_dict that directly supports punk::lib::tstr templating - #rename get_dict - # - - #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 get_dict {args} { - #see arg_error regarding considerations around unhappy-path performance - - #consider a better API - # - e.g punk::args::parse ?-flag val?... $arglist withid $id - # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? - #can the above be made completely unambiguous for arbitrary arglist?? - #e.g what if arglist = withdef and the first $def is also withdef ? - - - #*** !doctools - #[call [fun get_dict] [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 values - #[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 defining a flag 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 - #[para]Each optionspec line defining a positional argument is of the form: - #[para]argumentname -key val -ky2 val2... - #[para]where the valid keys for each option specification are: -default -type -range -choices - #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value - #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. - #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. - #[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, - #but it could be a manually constructed list of values made for example from positional args defined in the proc. - #[list_end] - #[para] - - #consider line-processing example below for which we need info complete to determine record boundaries - #punk::args::get_dict { - # @opts - # -opt1 -default {} - # -opt2 -default { - # etc - # } - # @values -multiple 1 - #} $args - - set rawargs [lindex $args end] ;# args values to be parsed - #we take a definition list rather than argspecs - because the definition could be dynamic - set definition_args [lrange $args 0 end-1] - - #if definition has been seen before, - #define will either return a permanently cached argspecs (-dynamic 0) - or - # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. - set argspecs [uplevel 1 [list ::punk::args::resolve {*}$definition_args]] - - # ----------------------------------------------- - # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) - tcl::dict::with argspecs {} ;#turn keys into vars - # TODO - capitalise 'define' vars to make it a bit easier - # ----------------------------------------------- - - #puts "-arg_info->$arg_info" - set flagsreceived [list] ;#for checking if required flags satisfied - #secondary purpose: - #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 ? - - # -- --- --- --- - # Handle leading positionals - # todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ? - set opts $opt_defaults - set pre_values {} - - set argnames [tcl::dict::keys $ARG_INFO] - set optnames [lsearch -all -inline $argnames -*] - set ridx 0 - set rawargs_copy $rawargs - set leader_posn_name "" - set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) - set is_multiple 0 ;#last leader may be multi - if {$LEADER_MAX != 0} { - foreach r $rawargs_copy { - if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { - break - } - if {$ridx == [llength $LEADER_NAMES]-1} { - #at last named leader - set leader_posn_name [lindex $LEADER_NAMES $ridx] - if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { - set is_multiple 1 - } - } elseif {$ridx > [llength $LEADER_NAMES]-1} { - #beyond names - retain name if -multiple was true - if {!$is_multiple} { - set leader_posn_name "" - } - } else { - set leader_posn_name [lindex $LEADER_NAMES $ridx] ;#may return empty string - } - if {$r eq "--"} { - #review end of opts marker: '--' can't be a leader (but can be a value) - break - } - - #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option - if {[tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { - set matchopt [::tcl::prefix::match -error {} $optnames $r] - if {$matchopt ne ""} { - #flaglike matches a known flag - don't treat as leader - break - } - #if {![string match -* [lindex $argnames $ridx]]} {} - if {$leader_posn_name ne ""} { - #there is a named leading positional for this position - #The flaglooking value doesn't match an option - so treat as a leader - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - incr ridx - continue - } else { - break - } - } - - #for each branch - break or lappend - if {$leader_posn_name ne ""} { - if {$leader_posn_name ni $LEADER_REQUIRED} { - #optional leader - - #most adhoc arg processing will allocate based on number of args rather than matching choice values first - #(because a choice value could be a legitimate data value) - - #review - option to process in this manner? - #first check if the optional leader value is a match for a choice ? - #if {[dict exists $arg_info $leader_posn_name -choices]} { - # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] [lindex $rawargs 0]] - # if {$vmatch ne ""} { - # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values - # lappend pre_values [lpop rawargs 0] - # incr ridx - # continue - # } - #} - - #check if enough rawargs to fill any required values - if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { - break - } else { - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #required - if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { - #already accepted at least one value - requirement satisfied - now equivalent to optional - if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { - break - } - } - #if we didn't break - requirement is not yet satisfied, or is satisfied but stil enough rawargs for required values - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #unnamed leader - if {$LEADER_MIN ne "" } { - if {$ridx > $LEADER_MIN} { - break - } else { - #haven't reached LEADER_MIN - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - break - } - } - - incr ridx - } ;# end foreach r $rawargs_copy - } - - set argstate $ARG_INFO ;#argstate may have entries added - set arg_checks $ARG_CHECKS - - if {$LEADER_MIN eq ""} { - set leadermin 0 - } else { - set leadermin $LEADER_MIN - } - if {$LEADER_MAX eq ""} { - set leadermax -1 - } else { - set leadermax $LEADER_MAX - } - - #assert leadermax leadermin are numeric - #assert - rawargs has been reduced by leading positionals - - set leaders [list] - set arglist {} - set post_values {} - #val_min, val_max - #puts stderr "rawargs: $rawargs" - #puts stderr "argstate: $argstate" - if {[lsearch $rawargs -*] >= 0} { - #at least contains flaglike things.. - set maxidx [expr {[llength $rawargs] -1}] - if {$val_max == -1} { - set vals_total_possible [llength $rawargs] - set vals_remaining_possible $vals_total_possible - } else { - set vals_total_possible $val_max - set vals_remaining_possible $vals_total_possible - } - for {set i 0} {$i <= $maxidx} {incr i} { - set a [lindex $rawargs $i] - set remaining_args_including_this [expr {[llength $rawargs] - $i}] - #lowest val_min is 0 - if {$remaining_args_including_this <= $val_min} { - # if current arg is -- it will pass through as a value here - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - - #exlude argument with whitespace from being a possible option e.g dict - if {[tcl::string::match -* $a] && !([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { - if {$a eq "--"} { - #remaining num args <= val_min already covered above - if {$val_max != -1} { - #finite max number of vals - if {$remaining_args_including_this == $val_max} { - #assume it's a value. - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - } else { - #assume it's an end-of-options marker - lappend flagsreceived -- - set arglist [lrange $rawargs 0 $i] - set post_values [lrange $rawargs $i+1 end] - } - } else { - #unlimited number of post_values accepted - #treat this as eopts - we don't care if remainder look like options or not - lappend flagsreceived -- - set arglist [lrange $rawargs 0 $i] - set post_values [lrange $rawargs $i+1 end] - } - break - } else { - set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] - if {$fullopt ne ""} { - if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { - #non-solo - #check if it was actually a value that looked like a flag - if {$i == $maxidx} { - #if no optvalue following - assume it's a value - #(caller should probably have used -- before it) - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - - set flagval [lindex $rawargs $i+1] - if {[tcl::dict::get $argstate $fullopt -multiple]} { - #don't lappend to default - we need to replace if there is a default - if {$fullopt ni $flagsreceived} { - tcl::dict::set opts $fullopt [list $flagval] - } else { - tcl::dict::lappend opts $fullopt $flagval - } - } else { - tcl::dict::set opts $fullopt $flagval - } - #incr i to skip flagval - incr vals_remaining_possible -2 - if {[incr i] > $maxidx} { - arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $fullopt - } - } else { - #solo - if {[tcl::dict::get $argstate $fullopt -multiple]} { - if {$fullopt ni $flagsreceived} { - #override any default - don't lappend to it - tcl::dict::set opts $fullopt 1 - } else { - tcl::dict::lappend opts $fullopt 1 - } - } else { - tcl::dict::set opts $fullopt 1 - } - incr vals_remaining_possible -1 - } - lappend flagsreceived $fullopt ;#dups ok - } else { - #unmatched option flag - #comparison to val_min already done above - if {$val_max ne -1 && $remaining_args_including_this <= $val_max} { - #todo - look at optspec_default and see if solo/vs opt-val pair - #we may need to lookahead by 2 regarding val_max val_min - - #even with optany - assume an unknown within the space of possible values is a value - #unmatched option in right position to be considered a value - treat like eopts - #review - document that an unspecified arg within range of possible values will act like eopts -- - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - if {$opt_any} { - set newval [lindex $rawargs $i+1] - #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option - tcl::dict::set argstate $a $optspec_defaults ;#use default settings for unspecified opt - tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS - if {[tcl::dict::get $argstate $a -type] ne "none"} { - if {[tcl::dict::get $argstate $a -multiple]} { - tcl::dict::lappend opts $a $newval - } else { - tcl::dict::set opts $a $newval - } - if {[incr i] > $maxidx} { - arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a - } - incr vals_remaining_possible -2 - } else { - #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none - if {[tcl::dict::get $argstate $a -multiple]} { - if {![tcl::dict::exists $opts $a]} { - tcl::dict::set opts $a 1 - } else { - tcl::dict::lappend opts $a 1 - } - } else { - tcl::dict::set opts $a 1 - } - incr vals_remaining_possible -1 - } - lappend flagsreceived $a ;#adhoc flag as supplied - } else { - if {[llength $OPT_NAMES]} { - set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $OPT_NAMES" - } else { - set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": No options defined while @opts -any 0" - } - arg_error $errmsg $argspecs -badarg $fullopt - } - } - } - } else { - #not flaglike - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - } - #set values [list {*}$pre_values {*}$post_values] - set leaders $pre_values - set values $post_values - } else { - set leaders $pre_values - set values $rawargs - #set values [list {*}$pre_values {*}$rawargs] ;#no -flags detected - set arglist [list] - } - #puts stderr "--> arglist: $arglist" - #puts stderr "--> values: $values" - - - set positionalidx 0 ;#index for unnamed positionals (both leaders and values) - set ldridx 0 - set in_multiple "" - set leadernames_received [list] - set leaders_dict $LEADER_DEFAULTS - set num_leaders [llength $leaders] - foreach leadername $LEADER_NAMES ldr $leaders { - if {$ldridx+1 > $num_leaders} { - break - } - if {$leadername ne ""} { - if {[tcl::dict::get $argstate $leadername -multiple]} { - if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { - tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list - } else { - tcl::dict::lappend leaders_dict $leadername $ldr - } - set in_multiple $leadername - } else { - tcl::dict::set leaders_dict $leadername $ldr - } - lappend leadernames_received $leadername - } else { - if {$in_multiple ne ""} { - tcl::dict::lappend leaders_dict $in_multiple $ldr - lappend leadernames_received $in_multiple ;#deliberately allow dups! (as with opts and values) - } else { - tcl::dict::set leaders_dict $positionalidx $ldr - tcl::dict::set argstate $positionalidx $leaderspec_defaults - tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS - lappend leadernames_received $positionalidx - } - } - incr ldridx - incr positionalidx - } - - set validx 0 - set in_multiple "" - set valnames_received [list] - set values_dict $val_defaults - set num_values [llength $values] - foreach valname $VAL_NAMES val $values { - if {$validx+1 > $num_values} { - break - } - if {$valname ne ""} { - if {[tcl::dict::get $argstate $valname -multiple]} { - if {[tcl::dict::exists $val_defaults $valname]} { - #current stored val equals defined default - don't include default in the list we build up - tcl::dict::set values_dict $valname [list $val] ;#important to treat first element as a list - } else { - tcl::dict::lappend values_dict $valname $val - } - set in_multiple $valname - } else { - tcl::dict::set values_dict $valname $val - } - lappend valnames_received $valname - } else { - if {$in_multiple ne ""} { - tcl::dict::lappend values_dict $in_multiple $val - #name already seen - but must add to valnames_received anyway (as with opts and leaders) - lappend valnames_received $in_multiple - } else { - tcl::dict::set values_dict $positionalidx $val - tcl::dict::set argstate $positionalidx $valspec_defaults - tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS - lappend valnames_received $positionalidx - } - } - incr validx - incr positionalidx - } - - if {$leadermax == -1} { - #only check min - if {$num_leaders < $leadermin} { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leadermin" $argspecs - } - } else { - if {$num_leaders < $leadermin || $num_leaders > $leadermax} { - if {$leadermin == $leadermax} { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leadermin" $argspecs - } else { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" $argspecs - } - } - } - - if {$val_max == -1} { - #only check min - if {$num_values < $val_min} { - arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected at least $val_min" $argspecs - } - } else { - if {$num_values < $val_min || $num_values > $val_max} { - if {$val_min == $val_max} { - arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected exactly $val_min" $argspecs - } else { - arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected between $val_min and $val_max inclusive" $argspecs - } - } - } - - #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options - - - #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 SHOULD? 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 - - #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? - #example timing difference: - #struct::set difference {x} {a b} - #normal interp 0.18 u2 vs safe interp 9.4us - #if {[llength [set missing [struct::set difference $opt_required $flagsreceived]]]} { - # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" - #} - #if {[llength [set missing [struct::set difference $val_required $valnames_received]]]} { - # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" - #} - #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us - if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { - arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - if {[llength [set missing [punklib_ldiff $opt_required $flagsreceived]]]} { - arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs - } - if {[llength [set missing [punklib_ldiff $val_required $valnames_received]]]} { - arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - - - #todo - truncate/summarize values in error messages - - #todo - allow defaults outside of choices/ranges - - #check types,ranges,choices - set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] - #set combined_defaults [tcl::dict::merge $val_defaults $opt_defaults] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash - #puts "---opts_and_values:$opts_and_values" - #puts "---argstate:$argstate" - tcl::dict::for {argname v} $opts_and_values { - set thisarg [tcl::dict::get $argstate $argname] - #set thisarg_keys [tcl::dict::keys $thisarg] - set thisarg_checks [tcl::dict::get $arg_checks $argname] - set is_multiple [tcl::dict::get $thisarg -multiple] - set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] - set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] - set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] - set has_default [tcl::dict::exists $thisarg -default] - if {$has_default} { - set defaultval [tcl::dict::get $thisarg -default] - } - set type [tcl::dict::get $thisarg -type] - set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] - set regexprepass [tcl::dict::get $thisarg -regexprepass] - set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 - set validationtransform [tcl::dict::get $thisarg -validationtransform] - - - if {$is_multiple} { - set vlist $v - } else { - set vlist [list $v] - } - set vlist_original $vlist ;#retain for possible final strip_ansi - - #review - validationtransform - if {$is_validate_ansistripped} { - #validate_ansistripped 1 - package require punk::ansi - set vlist_check [list] - foreach e $vlist { - lappend vlist_check [punk::ansi::ansistrip $e] - } - } else { - #validate_ansistripped 0 - set vlist_check $vlist - } - - #reduce our validation requirements by removing values which match defaultval or match -choices - #(could be -multiple with -choicerestriction 0 where some selections match and others don't) - if {$has_choices} { - #-choices must also work with -multiple - #todo -choicelabels - set choiceprefix [tcl::dict::get $thisarg -choiceprefix] - set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] - set choicerestricted [tcl::dict::get $thisarg -choicerestricted] - set choicemultiple [tcl::dict::get $thisarg -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set nocase [tcl::dict::get $thisarg -nocase] - set choices [Dict_getdef $thisarg -choices {}] - set choicegroups [Dict_getdef $thisarg -choicegroups {}] - set allchoices $choices - if {[dict size $choicegroups]} { - dict for {groupname groupmembers} $choicegroups { - lappend allchoices {*}$groupmembers - } - } - #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups - #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes - - - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - set dname leaders_dict - } - option { - set dname opts - } - value { - set dname values_dict - } - } - set idx 0 ;# - #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes - #assert llength $vlist == llength [dict get $dname $argname] - # (unless there was a default and the option wasn't specified) - set vlist_validate [list] - set vlist_check_validate [list] - foreach e $vlist e_check $vlist_check { - set allchoices_in_list 0 - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - #vlist and vlist_check can be list of lists if -multiple and -choicemultiple - #each e represents 0 or more choice selections - set c_list $e - set c_check_list $e_check - #todo? check if entire list matches default? - } else { - #only one choice at a time - ensure single entry in c_list c_check_list - set c_list [list $e] - set c_check_list [list $e_check] - } - - - #----------------------------------- - #fast fail on the wrong number of choices - if {[llength $c_list] < $choicemultiple_min} { - set msg "Option $argname for [Get_caller] requires at least $choicemultiple_min choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { - set msg "Option $argname for [Get_caller] requires at most $choicemultiple_max choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - #----------------------------------- - - set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list - foreach c $c_list c_check $c_check_list { - if {$nocase} { - set casemsg " (case insensitive)" - set choices_test [tcl::string::tolower $allchoices] - #Don't lcase the denylist - even in nocase mode! - #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] - set v_test [tcl::string::tolower $c_check] - } else { - set casemsg " (case sensitive)" - set v_test $c_check - set choices_test $allchoices - } - set choice_in_list 0 - set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? - if {!$matches_default} { - if {$choiceprefix} { - #can we handle empty string as a choice? It should just work - REVIEW/test - set choice_exact_match 0 - if {$c_check in $allchoices} { - #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing - set chosen $c_check - set choice_in_list 1 - set choice_exact_match 1 - } elseif {$v_test in $choices_test} { - #assert - if we're here, nocase must be true - #we know choice is present as full-length match except for case - #now we want to select the case from the choice list - not the supplied value - #we don't set choice_exact_match - because we will need to override the optimistic existing val below - #review - foreach avail [lsort -unique $allchoices] { - if {[string match -nocase $c $avail]} { - set chosen $avail - } - } - #assert chosen will always get set - set choice_in_list 1 - } else { - #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. - #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. - #in this block we can treat empty result from prefix match as a non-match - if {$nocase} { - #nocase implies that our entered value doesn't have to match case of choices - - #but we would still like to select the best match if there are case-dups. - #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete - # selecting Del will find Delete, del will match delete (and raise error) - # but DEL will also match delete rather than Delete - so again an error is raised. - #This is counterintuitive with -nocase - #This is probably such an edge case that best served with documentation as a feature-not-bug - #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? - #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. - - set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] - if {$bestmatch eq ""} { - set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] - #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing - set chosen [lsearch -inline -nocase $allchoices $chosen] - set choice_in_list [expr {$chosen ne ""}] - } else { - set chosen $bestmatch - set choice_in_list 1 - } - } else { - set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] - if {$chosen eq ""} { - set choice_in_list 0 - } else { - set choice_in_list 1 - } - } - #override choice_in_list if in deny list - #don't allow prefixing for elements from -choiceprefixdenylist - #we still use all elements to calculate the prefixes though - #review - case difference edge cases in choiceprefixdenylist !todo - if {$chosen in $choiceprefixdenylist} { - set choice_in_list 0 - set chosen "" - } - } - - #override the optimistic existing val - if {$choice_in_list && !$choice_exact_match} { - if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { - if {$is_multiple} { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $idx $chosen - tcl::dict::set $dname $argname $existing - } else { - tcl::dict::set $dname $argname $chosen - } - } else { - if {$is_multiple} { - set existing_all [tcl::dict::get [set $dname] $argname] - lset existing_all $idx $choice_idx $chosen - tcl::dict::set $dname $argname $existing_all - } else { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $choice_idx $chosen - tcl::dict::set $dname $argname $existing - } - } - } - } else { - #value as stored in $dname is ok - set choice_in_list [expr {$v_test in $choices_test}] - } - } - - if {!$choice_in_list && !$matches_default} { - if {!$choicerestricted} { - #if {$is_multiple} { - # set existing [tcl::dict::get [set $dname] $argname] - # lset existing $idx $v_test - # tcl::dict::set $dname $argname $existing - #} else { - # tcl::dict::set $dname $argname $v_test - #} - lappend vlist_validate $c - lappend vlist_check_validate $c_check - } else { - #unhappy path - if {$choiceprefix} { - set prefixmsg " (or a unique prefix of a value)" - } else { - set prefixmsg "" - } - arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname - } - } - incr choice_idx - } - - incr idx - } - #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation - #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - - if {[llength $vlist] && $has_default} { - set vlist_validate [list] - set vlist_check_validate [list] - foreach c $vlist c_check $vlist_check { - #for -choicemultiple with default that could be a list use 'ni' ?? review - if {$c_check ne $defaultval} { - lappend vlist_validate $c - lappend vlist_check_validate $c - } - } - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - - #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups - #assert: our vlist & vlist_check lists have been reduced to remove those - if {[llength $vlist] && !$is_allow_ansi} { - #allow_ansi 0 - package require punk::ansi - #do not run ta::detect on a list - foreach e $vlist { - if {[punk::ansi::ta::detect $e]} { - error "Option $argname for [Get_caller] contains ansi - but -allow_ansi is false. Received: '$e'" - } - } - } - #puts "argname:$argname v:$v is_default:$is_default" - #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. - #arguments that are at their default are not subject to type and other checks - - #don't validate defaults or choices that matched - #puts "---> opts_and_values: $opts_and_values" - #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" - #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} - - #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups - #assert [llength $vlist] == [llength $vlist_check] - if {[llength $vlist]} { - 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 -badarg $argname - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[llength $e_check] < $checkval} { - arg_error "Option $argname for [Get_caller] requires list with -minsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[llength $e_check] > $checkval} { - arg_error "Option $argname for [Get_caller] requires list with -maxsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - } - } - } - } - } - } - string - ansistring - globstring { - #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string - #we possibly don't want to always have to regex on things that don't pass the other more basic checks - # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) - # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) - # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead - # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function - # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) - # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail - - #todo? - way to validate both unstripped and stripped? - set pass_quick_list_e [list] - set pass_quick_list_e_check [list] - set remaining_e $vlist - set remaining_e_check $vlist_check - #review - order of -regexprepass and -regexprefail in original rawargs significant? - #for now -regexprepass always takes precedence - if {$regexprepass ne ""} { - foreach e $vlist e_check $vlist_check { - if {[regexp $regexprepass $e]} { - lappend pass_quick_list_e $e - lappend pass_quick_list_e_check $e_check - } - } - set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] - set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] - } - if {$regexprefail ne ""} { - foreach e $remaining_e e_check $remaining_e_check { - #puts "----> checking $e vs regex $regexprefail" - if {[regexp $regexprefail $e]} { - if {[tcl::dict::exists $thisarg -regexprefailmsg]} { - set msg [tcl::dict::get $thisarg -regexprefailmsg] - } else { - set msg "Option $argname for [Get_caller] didn't pass regexprefail regex: '$regexprefail' got '$e'" - } - arg_error $msg $argspecs -badarg $argname - } - } - } - switch -- $type { - ansistring { - #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi - #.. so we need to look at the original values in $vlist not $vlist_check - - #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? - #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? - package require punk::ansi - foreach e $remaining_e { - if {![punk::ansi::ta::detect $e]} { - arg_error "Option $argname for [Get_caller] requires ansistring - but no ansi detected" $argspecs -badarg $argname - } - } - } - globstring { - foreach e $remaining_e { - if {![regexp {[*?\[\]]} $e]} { - arg_error "Option $argname for [Get_caller] requires globstring - but no glob characters detected" $argspecs -badarg $argname - } - } - } - } - - if {[tcl::dict::size $thisarg_checks]} { - foreach e_check $remaining_e_check { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[tcl::string::length $e_check] < $checkval} { - arg_error "Option $argname for [Get_caller] requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::string::length $e_check] > $checkval} { - arg_error "Option $argname for [Get_caller] requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - } - } - } - } - } - } - int { - #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive - if {[tcl::dict::exists $thisarg -range]} { - lassign [tcl::dict::get $thisarg -range] low high - if {"$low$high" ne ""} { - if {$low eq ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname - } - #lowside unspecified - check only high - if {$e_check > $high} { - arg_error "Option $argname for [Get_caller] must be integer less than or equal to $high. Received: '$e'" $argspecs -badarg $argname - } - } - } elseif {$high eq ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname - } - #highside unspecified - check only low - if {$e_check < $low} { - arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs -badarg $argname - } - } - } else { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname - } - #high and low specified - if {$e_check < $low || $e_check > $high} { - arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs -badarg $argname - } - } - } - } - } else { - foreach e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e_check'" $argspecs -badarg $argname - } - } - } - } - double { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is double -strict $e_check]} { - error "Option $argname for [Get_caller] requires type 'double'. Received: '$e'" - } - if {[tcl::dict::size $thisarg_checks]} { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -range { - #todo - small-value double comparisons with error-margin? review - #todo - empty string for low or high - lassign $checkval low high - if {$e_check < $low || $e_check > $high} { - arg_error "Option $argname for [Get_caller] must be between $low and $high. Received: '$e'" $argspecs -badarg $argname - } - } - } - } - } - } - } - bool { - foreach e_check $vlist_check { - if {![tcl::string::is boolean -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'boolean'. Received: '$e_check'" $argspecs -badarg $argname - } - } - } - dict { - foreach e_check $vlist_check { - 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 -badarg $argname - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -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 -minsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::dict::size $e_check] > $checkval} { - arg_error "Option $argname for [Get_caller] requires dict with -maxsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - } - } - } - } - } - } - alnum - - alpha - - ascii - - control - - digit - - graph - - lower - - print - - punct - - space - - upper - - wordchar - - xdigit { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is $type $e_check]} { - set msg "Option $argname for [Get_caller] requires type '$type'. Received: '$e'" - #try trap? - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type]]] $result - #throw ? - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname]] $msg - arg_error $msg $argspecs -badarg $argname - } - } - } - file - - directory - - existingfile - - existingdirectory { - foreach e $vlist e_check $vlist_check { - #//review - we may need '?' char on windows - if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { - #what about special file names e.g on windows NUL ? - arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" $argspecs -badarg $argname - } - } - if {$type eq "existingfile"} { - foreach e $vlist e_check $vlist_check { - if {![file exists $e_check]} { - arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing file" $argspecs -badarg $argname - } - } - } elseif {$type eq "existingdirectory"} { - foreach e $vlist e_check $vlist_check { - if {![file isdirectory $e_check]} { - arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing directory" $argspecs -badarg $argname - } - } - } - } - char { - foreach e $vlist e_check $vlist_check { - if {[tcl::string::length $e_check] != 1} { - arg_error "Option $argname for [Get_caller] requires type 'character'. Received: '$e' which is not a single character" $argspecs -badarg $argname - } - } - } - } - - } - - if {$is_strip_ansi} { - set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach - if {[tcl::dict::get $thisarg -multiple]} { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict $argname $stripped_list - } - option { - tcl::dict::set opts $argname $stripped_list - } - value { - tcl::dict::set values_dict $argname $stripped_list - } - } - } else { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict [lindex $stripped_list 0] - } - option { - tcl::dict::set opts $argname [lindex $stripped_list 0] - } - value { - tcl::dict::set values_dict [lindex $stripped_list 0] - } - } - } - } - } - - #maintain order of opts $opts values $values as caller may use lassign. - set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] - if {[llength $receivednames]} { - #flat zip of names with overall posn, including opts - #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] - set i -1 - set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] - } else { - set received_posns [list] - } - #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) - #(e.g using 'dict exists $received -flag') - # - but it can have duplicate keys when args/opts have -multiple 1 - #It is actually a list of paired elements - return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns] - } - - #proc sample1 {p1 args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [opt {?option value...?}]] - # #[para]Description of sample1 - # return "ok" - #} - - - lappend PUNKARGS [list { - @id -id ::punk::args::TEST - @opts -optional 0 - -o1 -default 111 -help "opt 1 mandatory" - @opts -optional 1 - -o2 -default 222 -help "opt 2 optional" - @values -min 0 -max 1 - v -help\ - "v1 optional" - }] - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::lib { - variable PUNKARGS - tcl::namespace::export * - tcl::namespace::path [list [tcl::namespace::parent]] - #*** !doctools - #[subsection {Namespace punk::args::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 flatzip {l1 l2} { - concat {*}[lmap a $l1 b $l2 {list $a $b}] - } - - if {[info commands lseq] ne ""} { - #tcl 8.7+ lseq significantly faster, especially for larger ranges - #The internal rep can be an 'arithseries' with no string representation - proc zero_based_posns {count} { - if {$count < 1} {return} - lseq 0 $count-1 - } - } else { - proc zero_based_posns {count} { - if {$count < 1} {return} - lsearch -all [lrepeat $count 0] * - } - } - - - #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 -1] in calling scope ${[lindex [set x] 0]} !} - lappend PUNKARGS [list { - @id -id ::punk::args::lib::tstr - @cmd -name punk::args::lib::tstr -help\ - "A rough equivalent of js template literals - - Substitutions: - \$\{$varName\} - \$\{[myCommand]\} - (when -allowcommands flag is given)" - -allowcommands -default 0 -type none -help\ - "If -allowcommands is present, placeholder can contain commands - e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" - -undent -default 1 -type boolean -help\ - "undent/dedent the template lines. - The longest common prefix of whitespace is removed" - -indent -default "" -type string -help\ - "String with which to indent the template - prior to substitution. - If -undent is enabled, that is performed - first, then the indent is applied." - -paramindents -default line -choices {none line position} -choicelabels { - line\ - " Use leading whitespace in - the line in which the - placeholder occurs." - position\ - " Use the position in - the line in which the - placeholder occurs." - none\ - " No indents applied to - subsequent placeholder value - lines. This will usually - result in text awkwardly - ragged unless the source code - has also been aligned with the - left margin or the value has - been manually padded." - } -help\ - "How indenting is done for subsequent lines in a - multi-line placeholder substitution value. - The 1st line or a single line value is always - placed at the placeholder. - paramindents are performed after the main - template has been indented/undented. - (indenting by position does not calculate - unicode double-wide or grapheme cluster widths) - " - #choicelabels indented by 1 char is clearer for -return string - and reasonable in table - -return -default string -choices {dict list string args}\ - -choicelabels { - dict\ - " Return a dict with keys - 'template', 'params' and - 'errors'" - string\ - " Return a single result - being the string with - placeholders substituted." - list\ - " Return a 2 element list. - The first is itself a list - of plaintext portions of the - template, split at each point - at which placeholders were - present. The second element - of the outer list is a list - of placeholder values if -eval - is 1, or a list of the raw - placeholder strings if -eval - is 0." - args\ - " Return a list where the first - element is a list of template - plaintext sections as per the - 'list' return mechanism, but the - placeholder items are individual - items in the returned list. - This can be useful when passing - the expanded result of a tstr - command to another function - which expects the placeholders - as individual arguments" - } - -eval -default 1 -type boolean -help\ - "Whether to evaluate the \$\{\} placeholders. - When -return is string, -eval should generally be set to 1. - For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. - contained variables in that case should be braced or whitespace separated, or the variable - name is likely to collide with surrounding text. - e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" - @values -min 0 -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 - e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} - - Escape sequences such as \\n and unicode escapes are processed within placeholders. - " - }] - - proc tstr {args} { - #Too hard to fully eat-our-own-dogfood from within punk::args package - # - we use punk::args within the unhappy path only - #set argd [punk::args::get_by_id ::punk::lib::tstr $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 opt_eval [dict get $argd opts -eval] - - set templatestring [lindex $args end] - set arglist [lrange $args 0 end-1] - set opts [dict create\ - -allowcommands 0\ - -undent 1\ - -indent ""\ - -paramindents line\ - -eval 1\ - -return string\ - ] - if {"-allowcommands" in $arglist} { - set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] - dict set opts -allowcommands 1 - } - if {[llength $arglist] % 2 != 0} { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr expected option/value pairs prior to last argument" - } - } - dict for {k v} $arglist { - set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] - switch -- $fullk { - -indent - -undent - -paramindents - -return - -eval { - dict set opts $fullk $v - } - default { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" - } - } - } - } - set opt_allowcommands [dict get $opts -allowcommands] - set opt_paramindents [dict get $opts -paramindents] - set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] - if {$test_paramindents ni {none line position}} { - error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." - } - set opt_paramindents $test_paramindents - set opt_return [dict get $opts -return] - set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] - if {$opt_return eq ""} { - } - set opt_eval [dict get $opts -eval] - - - set nocommands "-nocommands" - if {$opt_allowcommands == 1} { - set nocommands "" - } - - set opt_undent [dict get $opts -undent] - if {$opt_undent} { - set templatestring [punk::args::lib::undent $templatestring] - } - set opt_indent [dict get $opts -indent] - if {$opt_indent ne ""} { - set templatestring [punk::args::lib::indent $templatestring $opt_indent] - } - - #set parts [_tstr_split $templatestring] - if {[string first \$\{ $templatestring] < 0} { - set parts [list $templatestring] - } else { - set parts [_parse_tstr_parts $templatestring] - } - set textchunks [list] - #set expressions [list] - set params [list] - set idx 0 - set errors [dict create] - set lastline "" ;#todo - first line has placeholder? - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach {pt expression} $parts { - lappend textchunks $pt - incr idx ;#pt incr - - #ignore last expression - if {$idx == [llength $parts]} { - break - } - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - #lappend expressions $expression - #---------------------- - #REVIEW - JMN - #TODO - debug punk::args loading of @dynamic defs - #puts "-- $expression" - #---------------------- - #brk1 - literal newline not {\n} - set leader "" - if {[set brk1 [string first \n $expression]] >= 0} { - #undent left of paramstart only for lines of expression that arent on opening ${..} line - set tail [string range $expression $brk1+1 end] - set leader [string repeat " " [string length $lastline]] - set undentedtail [punk::args::lib::undentleader $tail $leader] - #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] - set expression "[string range $expression 0 $brk1]$undentedtail" - } - if {$opt_eval} { - if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { - lappend params [string cat \$\{ $expression \}] - dict set errors [expr {[llength $params]-1}] $result - } else { - set result [string map [list \n "\n$leader"] $result] - lappend params $result - } - #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] - } else { - lappend params [subst -nocommands -novariables $expression] - } - append lastline [lindex $params end] ;#for current expression's position calc - - incr idx ;#expression incr - } - - if {$opt_return eq "dict"} { - return [dict create template $textchunks params $params errors $errors] - } - if {[dict size $errors]} { - set einfo "" - dict for {i e} $errors { - append einfo "parameter $i error: $e" \n - } - #REVIEW!!! - #TODO - fix - #puts stderr "tstr errors:\n$einfo\n" - } - - switch -- $opt_return { - list { - return [list $textchunks $params] - } - args { - #see example in tstr_test_one - return [list $textchunks {*}$params] - } - string { - #todo - flag to disable indent-matching behaviour for multiline param? - set out "" - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach pt $textchunks param $params { - if {$opt_paramindents eq "none"} { - append out $pt $param - } else { - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - if {$opt_paramindents eq "line"} { - regexp {(\s*).*} $lastline _all lastindent - } else { - #position - #TODO - detect if there are grapheme clusters - #This regsub doesn't properly space unicode double-wide chars or clusters - set lastindent "[regsub -all {\S} $lastline " "] " - } - if {$lastindent ne ""} { - set paramlines [split $param \n] - if {[llength $paramlines] == 1} { - append out $pt $param - } else { - append out $pt [lindex $paramlines 0] - foreach nextline [lrange $paramlines 1 end] { - append out \n $lastindent $nextline - } - } - } else { - append out $pt $param - } - append lastline $param - } - } - return $out - } - } - } - #test single placeholder tstr args where single placeholder must be an int - proc tstr_test_one {args} { - set argd [punk::args::get_dict { - @cmd -name ::punk::args::lib::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 -return args {Select * from table where id = \$\{$id\} and etc... ;}] - } - - @values -min 2 -max 2 - template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - - but the tstr call in the example 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]] ""] - set result [string cat [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 dollar sign - 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]] - } - - #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. - proc indent {text {prefix " "}} { - set result [list] - foreach line [split $text \n] { - if {[string trim $line] eq ""} { - lappend result "" - } else { - lappend result $prefix[string trimright $line] - } - } - return [join $result \n] - } - #dedent? - proc undent {text} { - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - regexp {^([\t ]*)} $lcp _m lcp - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - - #hacky - proc undentleader {text leader} { - #leader usually whitespace - but doesn't have to be - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - lappend nonblank "${leader}!!" - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - #regexp {^([\t ]*)} $lcp _m lcp - #lcp can be shorter than leader - set lcp [string range $lcp 0 [string length $leader]-1] - - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - #A version of textutil::string::longestCommonPrefixList - proc longestCommonPrefix {items} { - if {[llength $items] <= 1} { - return [lindex $items 0] - } - set items [lsort $items[unset items]] - set min [lindex $items 0] - set max [lindex $items end] - #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) - #(sort order nothing to do with length - e.g min may be longer than max) - if {[string length $min] > [string length $max]} { - set temp $min - set min $max - set max $temp - } - set n [string length $min] - set prefix "" - set i -1 - while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { - append prefix $c - } - return $prefix - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] -} - -tcl::namespace::eval punk::args::argdocbase { - namespace export * - #use a? to test and create literal ansi here rather than relying on punk::ansi package presence - #e.g - #% a? bold - #- bold │SGR 1│sample│␛[1msample - #- ──────┼─────┼──────┼────────── - #- RESULT│ │sample│␛[1msample - proc B {} {return \x1b\[1m} ;#a+ bold - proc N {} {return \x1b\[22m} ;#a+ normal - proc I {} {return \x1b\[3m} ;#a+ italic - proc NI {} {return \x1b\[23m} ;#a+ noitalic - -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::package { - variable PUNKARGS - lappend PUNKARGS [list { - @dynamic - @id -id "::punk::args::package::standard_about" - @cmd -name "%pkg%::about" -help\ - "About %pkg% - ... - " - -package_about_namespace -type string -optional 0 -help\ - "Namespace containing the package about procedures - Must contain " - -return\ - -type string\ - -default table\ - -choices {string table tableobject}\ - -choicelabels { - string\ - "A basic text layout" - table\ - "layout in table borders - (requires package: textblock)" - tableobject\ - "textblock::class::table object instance" - }\ - -help\ - "Choose the return type of the 'about' information" - topic -optional 1\ - -nocase 1\ - -default {*}\ - -choices {Description License Version Contact *}\ - -choicerestricted 0\ - -choicelabels { - - }\ - -multiple 1\ - -help\ - "Topic to display. Omit or specify as * to see all. - If * is included with explicit topics, * represents - the remaining unmentioned topics." - }] - proc standard_about {args} { - set argd [punk::args::parse $args withid ::punk::args::package::standard_about] - lassign [dict values $argd] leaders OPTS values received - - set pkgns [dict get $OPTS -package_about_namespace] - if {[info commands ${pkgns}::package_name] eq ""} { - error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" - } - set pkgname [${pkgns}::package_name] - - set opt_return [dict get $OPTS -return] - set all_topics [${pkgns}::about_topics] - if {![dict exists $received topic]} { - set topics $all_topics - } else { - # * represents all remaining topics not explicitly mentioned. - set val_topics [dict get $values topic] ;#if -multiple is true, this is a list - set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] - set topics [list] - foreach t $val_topics { - if {$t eq "*"} { - foreach a $all_topics { - if {$a ni $explicit_topics} { - lappend topics $a - } - } - } else { - lappend topics $t - } - } - } - if {$opt_return ne "string"} { - package require textblock ;#table support - set is_table 1 - set title [string cat {[} $pkgname {]} ] - set t [textblock::class::table new -title $title] - $t configure -frametype double -minwidth [expr {[string length $title]+2}] - - } else { - set topiclens [lmap t $topics {string length $t}] - set widest_topic [tcl::mathfunc::max {*}$topiclens] - set is_table 0 - set about "$pkgname\n" - append about [string repeat - $widest_topic] \n - } - foreach topic $topics { - if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { - set topic_contents [::${pkgns}::get_topic_$topic] - } else { - set topic_contents "" - } - if {!$is_table} { - set content_lines [split $topic_contents \n] - append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n - foreach ln [lrange $content_lines 1 end] { - append about [format %-${widest_topic}s ""] " " $ln \n - } - } else { - $t add_row [list $topic $topic_contents] - } - } - - if {!$is_table} { - return $about - } else { - if {$opt_return eq "tableobject"} { - return $t - } - set result [$t print] - $t destroy - return $result - } - } - -} - -#usually we would directly call arg definitions near the defining proc, -# so that the proc could directly use the definition in its parsing. -# -#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. -#arguably it may be more processor-cache-efficient to do together like this anyway. - -#can't do this here? - as there is circular dependency with punk::lib -#tcl::namespace::eval punk::args { -# foreach deflist $PUNKARGS { -# punk::args::define {*}$deflist -# } -# set PUNKARGS "" -#} - -lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -tcl::namespace::eval punk::args::system { - #*** !doctools - #[subsection {Namespace punk::args::system}] - #[para] Internal functions that are not part of the API - - #dict get value with default wrapper for tcl 8.6 - if {[info commands ::tcl::dict::getdef] eq ""} { - proc Dict_getdef {dictValue args} { - set keys [lrange $args 0 end-1] - if {[tcl::dict::exists $dictValue {*}$keys]} { - return [tcl::dict::get $dictValue {*}$keys] - } else { - return [lindex $args end] - } - } - } else { - #we pay a minor perf penalty for the wrap - interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef - } - - #name to reflect maintenance - home is punk::lib::ldiff - proc punklib_ldiff {fromlist removeitems} { - if {[llength $removeitems] == 0} {return $fromlist} - set result {} - foreach item $fromlist { - if {$item ni $removeitems} { - lappend result $item - } - } - return $result - } - -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::args [tcl::namespace::eval punk::args { - tcl::namespace::path {::punk::args::lib ::punk::args::system} - variable pkg punk::args - variable version - set version 0.1.0 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.1.tm deleted file mode 100644 index 2d8de97d..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.1.tm +++ /dev/null @@ -1,5341 +0,0 @@ -# -*- 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: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.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 punk::args 0.1.0 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.1.0] -#[copyright "2024"] -#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] -#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] -#[require punk::args] -#[keywords module proc args arguments parse] -#[description] -#[para]Utilities for parsing proc args - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). -#[para] overview of punk::args -#[subsection Concepts] -#[para]There are 2 main conventions for parsing a proc args list -#[list_begin enumerated] -#[enum] -#[para]leading option-value pairs and flags followed by a list of values (Tcl style) -#[enum] -#[para]leading list of values followed by option-value pairs and flags (Tk style) -#[list_end] -#[para]There are exceptions in both Tcl and Tk commands regarding this ordering -#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style -#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] -#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. -#[para] -#[para]The basic principle is that a call to punk::args::get_dict is made near the beginning of the proc with a cacheable first argument defining the parameters e.g -#[example { -# proc dofilestuff {args} { -# lassign [dict values [punk::args::get_dict { -# @cmd -help "do some stuff with files e.g dofilestuff " -# @opts -type string -# #comment lines ok -# -directory -default "" -# -translation -default binary -# #setting -type none indicates a flag that doesn't take a value (solo flag) -# -nocomplain -type none -# @values -min 1 -max -1 -# } $args]] leaders opts values -# -# puts "translation is [dict get $opts -translation]" -# foreach f [dict values $values] { -# puts "doing stuff with file: $f" -# } -# } -#}] -#[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls -#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values -#[para]valid @ lines being with @cmd @leaders @opts @values -#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. -#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. -#[para]e.g the result from the punk::args call above may be something like: -#[para] opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} -#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments -#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments -#[example { -# proc dofilestuff {category args} { -# lassign [dict values [punk::args::get_dict { -# -directory -default "" -# -translation -default binary -# -nocomplain -type none -# @values -min 2 -max 2 -# fileA -type existingfile 1 -# fileB -type existingfile 1 -# } $args]] leaders opts values -# puts "$category fileA: [dict get $values fileA]" -# puts "$category fileB: [dict get $values fileB]" -# } -#}] -#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 -#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored -#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, -#[para] or an additional call could be made to punk::args e.g -#[example { -# punk::args::get_dict { -# category -choices {cat1 cat2 cat3} -# another_leading_arg -type boolean -# } [list $category $another_leading_arg] -#}] - -#*** !doctools -#[subsection Notes] -#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. -#[para] -#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. -#For functions that are part of an API a package may be more suitable. -#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) -#[example { -# proc test_switch {args} { -# set opts [dict create\\ -# -return "object"\\ -# -frametype "heavy"\\ -# -show_edge 1\\ -# -show_seps 0\\ -# -x a\\ -# -y b\\ -# -z c\\ -# -1 1\\ -# -2 2\\ -# -3 3\\ -# ] -# foreach {k v} $args { -# switch -- $k { -# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { -# dict set opts $k $v -# } -# default { -# error "unrecognised option '$k'. Known options [dict keys $opts]" -# } -# } -# } -# return $opts -# } -#}] -#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. -#[para] -# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. -# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. -#[para]use punk::lib::show_jump_tables to verify that a jump table exists. -#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous -#[example { -# proc test_prefix {args} { -# set opts [dict create\ -# -return string\ -# -frametype \uFFEF\ -# -show_edge \uFFEF\ -# -show_seps \uFFEF\ -# -x a\ -# -y b\ -# -z c\ -# -1 1\ -# -2 2\ -# -3 3\ -# ] -# if {[llength $args]} { -# set knownflags [dict keys $opts] -# } -# foreach {k v} $args { -# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v -# } -# return $opts -# } -#}] -#[para]There are many alternative args parsing packages a few of which are listed here. -#[list_begin enumerated] -#[enum]argp (pure tcl) -#[enum]parse_args (c implementation) -#[enum]argparse (pure tcl *) -#[enum]cmdline (pure tcl) -#[enum]opt (pure tcl) distributed with Tcl but considered deprecated -#[enum]The tcllib set of TEPAM modules (pure tcl) -#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. -#[list_end] -#[para] (* c implementation planned/proposed) -#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. -#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences -#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. -#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. -#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. -#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. -#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -#All ensemble commands are slower in a safe interp as they aren't compiled the same way -#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 -#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. -#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) -#ensembles: array binary clock dict info namespace string -#possibly file too, although that is generally hidden/modified in a safe interp -#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc -#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::args -#[list_begin itemized] -package require Tcl 8.6- -#optional? punk::trie -#optional? punk::textblock -#*** !doctools -#[item] [package {Tcl 8.6-}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -tcl::namespace::eval punk::args::register { - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] cooperative namespace punk::args::register - #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded - #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. - #[list_begin definitions] - - #Although the actual punk::args::define calls are not too sluggish, there could be *many*. - #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, - #especially since a fair proportion may be for documentation purposes rather than parsing args. - - # -- --- --- --- --- --- --- --- - #cooperative with packages that define some punk args but do so lazily - #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first - variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective - if {![info exists ::punk::args::register::NAMESPACES]} { - set ::punk::args::register::NAMESPACES [list] - } - # -- --- --- --- --- --- --- --- - - variable loaded_packages [list] ;#fully loaded - variable loaded_info [dict create] ;#time - variable scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages - variable scanned_info [dict create] ;#time and idcount - #some packages, e.g punk::args::tclcore document other namespaces. - #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources - variable namespace_docpackages [dict create] - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::register ---}] -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args { - - - variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. - - tcl::namespace::export {[a-z]*} - variable rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} - variable id_cache_rawdef [tcl::dict::create] - variable id_cache_spec [tcl::dict::create] - - variable argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) - - variable argdata_cache [tcl::dict::create] - - variable id_counter 0 - - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] Core API functions for punk::args - #[list_begin definitions] - - #todo - some sort of punk::args::cherrypick operation to get spec from an existing set - #todo - doctools output from definition - - - - - #todo? -synonym/alias ? (applies to opts only not values) - #e.g -background -aliases {-bg} -default White - #review - how to make work with trie prefix - #e.g - # -corner -aliases {-corners} - # -centre -aliases {-center -middle} - #We mightn't want the prefix to be longer just because of an alias - #we should get -co -ce and -m from the above as abbreviations - - set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] - - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::define - #todo @preamble -help "move large block outside of table?" - @cmd -name punk::args::define -help\ - "Accepts a line-based definition of command arguments. - Returns a dictionary representing the argument specifications. - - The return result can generally be ignored, as the record is stored keyed on the - @id -id value from the supplied definition. - This specifications dictionary is structured for (optional) use within commands to - parse and validate the arguments - and is also used when retrieving definitions - (or parts thereof) for re-use. - - This can be used purely for documentation or called within a function to parse a mix - of leading values, switches/flags and trailing values. - - The overhead is favourably comparable with other argument processors - but none are - as fast as minimal code with a switch statement. For toplevel commands where a few - 10s of microseconds is immaterial, the validation and automated error formatting in - a table can be well worthwhile. For inner procs requiring utmost speed, the call can - be made only on the unhappy path when basic processing determines a mismatch - or it - can be left entirely as documentation for interactive use with: i ... - - The definition should usually contain an initial line of the form: @id -id ::somecmd - - Blank lines are ignored at the top level, ie if they are not part of another structure. - Similarly - lines at the top level begginning with the # character are ignored. - All other toplevel lines must consist of a leading word followed by paired arguments. - The arguments can be spread over multiple lines and contain lines of near-arbitrary - text if they are properly braced or double quoted and Tcl escaping for inner quotes - or unbalanced braces is maintained. - The line continuation character - (\\ at the end of the line) can be used to continue the set of arguments for - a leading word. - Leading words beginning with the @ character are directives controlling argument - parsing and help display. - directives include: - %B%@id%N% ?opt val...? - spec-options: -id - %B%@cmd%N% ?opt val...? - spec-options: -name -help - %B%@leaders%N% ?opt val...? - spec-options: -min -max - (used for leading args that come before switches/opts) - %B%@opts%N% ?opt val...? - spec-options: -any - %B%@values%N% ?opt val...? - spec-options: -min -max - (used for trailing args that come after switches/opts) - %B%@argdisplay%N% ?opt val...? - spec-options: -header (text for header row of table) - -body (text to replace autogenerated arg info) - %B%@doc%N% ?opt val...? - spec-options: -name -url - %B%@seealso%N% ?opt val...? - spec-options: -name -url (for footer - unimplemented) - - Some other spec-options normally present on custom arguments are available - to use with the @leaders @opts @values directives to set defaults - for subsequent lines that represent your custom arguments. - These directives should occur in exactly this order - but can be - repeated with custom argument lines interspersed. - - An @id line can only appear once and should be the first item. - For the commandline usage to be displayed either on parsing error - or using the i .. function - an @id with -id is needed. - - All directives can be omitted, in which case every line represents - a custom leader, value or option. - All will be leaders by default if no options defined. - If options are defined (by naming with leading dash, or explicitly - specifying @opts) then the definitions prior to the options will be - categorised as leaders, and those following the options will be - categorised as values. - - Custom arguments are defined by using any word at the start of a - line that doesn't begin with @ or - - (except that adding an additionl @ escapes this restriction so - that @@somearg becomes an argument named @somearg) - - custom leading args, switches/options (names starting with -) - and trailing values also take spec-options: - - -type - defaults to string. If no other restrictions - are specified, choosing string does the least validation. - recognised types: - none - (used for switches only. Indicates this is - a 'solo' flag ie accepts no value) - int|integer - list - dict - double - bool|boolean - char - file - directory - string - ansistring - globstring - (any of the types accepted by 'string is') - - These all perform some validation checks - - and more.. (todo - document here) - - -optional - (defaults to true for flags/switches false otherwise) - For non flag/switch arguments - all arguments with - -optional true must sit consecutively within their group. - ie all optional leader arguments must be together, and all - optional value arguments must be together. Furthermore, - specifying both optional leaders and optional values will - often lead to ambiguous parsing results. Currently, all - optional non-flg/switch arguments should be either at the - trailing end of leaders or the trailing end of values. - Further unambiguous arrangements of optional args may be - made in future - but are currently considered 'unsupported' - -default - -multiple (for leaders & values defines whether - subsequent received values are stored against the same - argument name - only applies to final leader OR final value) - (for options/flags this allows the opt-val pair or solo - flag to appear multiple times - not necessarily contiguously) - -choices {} - A list of allowable values for an argument. - The -default value doesn't have to be in the list. - If a -type is specified - it doesn't apply to choice members. - It will only be used for validation if the -choicerestricted - option is set to false. - -choicerestricted - Whether values not specified in -choices or -choicegroups are - allowed. Defaults to true. - -choiceprefix - This specifies whether unique prefixes are able to be used - instead of the complete string. This is calculated using - tcl::prefix::match - and will display in the autogenerated - usage output. Defaults to true. - -choiceprefixdenylist {} - These choices should match exactly a choice entry in one of - the settings -choices or -choicegroups. - These will still be used in prefix calculation - but the full - choice argument must be entered to select the choice. - -choicegroups {} - Generally this would be used instead of -choices to allow - usage display of choices grouped by some name. - See for example the output if 'i zlib' where choices of the - next subcommand are grouped by the names compression,channel, - streaming and checksumming. The -choices list is equivalent - to a -choicegroups dict entry where the key (groupname) is - the empty string. - -choicemultiple (default {1 1}) - is a pair representing min and max number of choices - that can be present in the value. - If is a single integer it is equivalent to a - specified with the same integer for both min and max. - Max of -1 represents no upper limit. - If allows more than one choice the value is a list - consisting of items in the choices made available through - entries in -choices/-choicegroups. - -minsize (type dependant) - -maxsize (type dependant) - -range (type dependant) - - - " - -dynamic -type boolean -default 0 -help\ - "If -dynamic is true, tstr interpolations of the form \$\{\$var\} - are re-evaluated on each call. - If the definition is being used not just as documentation, but is also - used within the function to parse args, e.g using punk::args::get_by_id, - then it should be noted that there is a slight performance penalty for the - dynamic case. - It is often not significant, perhaps depending on what vars/commands are - used but -dynamic true might be less desirable if the command is used in - inner loops in more performance-sensitive code. - " - @values -min 1 -max -1 - text -type string -multiple 1 -help\ - "Block(s) of text representing the argument definition for a command. - At least one must be supplied. If multiple, they are joined together with \\n. - Using multiple text arguments may be useful to mix curly-braced and double-quoted - strings to have finer control over interpolation when defining arguments. - (this can also be handy for sections that pull resolved definition lines - from existing definitions (by id) for re-use of argument specifications and help text) - - e.g the following definition passes 2 blocks as text arguments - definition { - @id -id ::myns::myfunc - @cmd -name myns::myfunc -help\\ - \"Description of command\" - - #The following option defines an option-value pair - -option1 -default blah -type string - #The following option defines a flag style option (solo) - -flag1 -default 0 -type none -help\\ - \"Info about flag1 - subsequent help lines auto-dedented by whitespace to left - of corresponding record start (in this case -flag1) - + first 4 spaces if they are all present. - This line has no extra indent relative to first line 'Info about flag1' - This line indented a further 6 chars\" - - @values -min 1 -max -1 - #Items that don't begin with * or - are value definitions - v1 -type integer -default 0 - thinglist -type string -multiple 1 - } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" - " - }]] - - proc New_command_form {name} { - #probably faster to inline a literal dict create in the proc than to use a namespace variable - set leaderspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - set optspec_defaults [tcl::dict::create\ - -type string\ - -optional 1\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - set valspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - - #form record can have running entries such as 'argspace' that aren't given to arg parser - #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict - return [dict create\ - argspace "leaders"\ - ARG_INFO [tcl::dict::create]\ - ARG_CHECKS [tcl::dict::create]\ - LEADER_DEFAULTS [tcl::dict::create]\ - LEADER_REQUIRED {}\ - LEADER_NAMES {}\ - LEADER_MIN ""\ - LEADER_MAX ""\ - leaderspec_defaults $leaderspec_defaults\ - LEADER_CHECKS_DEFAULTS {}\ - opt_default {}\ - opt_required {}\ - OPT_NAMES {}\ - opt_any {}\ - opt_solos {}\ - optspec_defaults $optspec_defaults\ - OPT_CHECKS_DEFAULTS {}\ - val_defaults {}\ - val_required {}\ - VAL_NAMES {}\ - val_min ""\ - val_max ""\ - valspec_defaults $valspec_defaults\ - VAL_CHECKS_DEFAULTS {}\ - argdisplay_info ""\ - ] - - #set argdata_dict [tcl::dict::create\ - # id $DEF_definition_id\ - # arg_info $arg_info\ - # arg_checks $arg_checks\ - # leader_defaults $leader_defaults\ - # leader_required $leader_required\ - # leader_names $leader_names\ - # leader_min $leader_min\ - # leader_max $leader_max\ - # leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ - # leader_checks_defaults $leader_checks_defaults\ - # opt_defaults $opt_defaults\ - # opt_required $opt_required\ - # opt_names $opt_names\ - # opt_any $opt_any\ - # opt_solos $opt_solos\ - # optspec_defaults [dict get $F $firstformid optspec_defaults]\ - # opt_checks_defaults $opt_checks_defaults\ - # val_defaults $val_defaults\ - # val_required $val_required\ - # val_names $val_names\ - # val_min $val_min\ - # val_max $val_max\ - # valspec_defaults [dict get $F $firstformid valspec_defaults]\ - # val_checks_defaults $val_checks_defaults\ - # cmd_info $cmd_info\ - # doc_info $doc_info\ - # argdisplay_info $argdisplay_info\ - # id_info $id_info\ - # form_defs $F\ - #] - } - proc define {args} { - dict get [resolve {*}$args] id - } - proc resolve {args} { - variable rawdef_cache - variable id_cache_rawdef - if {[dict exists $rawdef_cache $args]} { - set id [dict get $rawdef_cache $args -id] - set is_dynamic [dict get $rawdef_cache $args -dynamic] - } else { - set id [rawdef_id $args] - set is_dynamic [rawdef_is_dynamic $args] - dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] - dict set id_cache_rawdef $id $args - } - - - variable argdata_cache - variable argdefcache_unresolved - - - set cache_key $args - #ideally we would use a fast hash algorithm to produce a short key with low collision probability. - #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) - #review - check if there is a built-into-tcl way to do this quickly - #for now we will just key using the whole string - #performance seems ok - memory usage probably not ideal - #quote from DKF 2021 - #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. - #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. - #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. - #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). - #> If dealing with very large amounts of data, using a database is probably a good plan. - - set textargs $args - if {![llength $args]} { - punk::args::get_by_id ::punk::args::define {} - return - } - if {[lindex $args 0] eq "-dynamic"} { - set is_dynamic [lindex $args 1] - set textargs [lrange $args 2 end] - } - - if {!$is_dynamic} { - if {[tcl::dict::exists $argdata_cache $cache_key]} { - return [tcl::dict::get $argdata_cache $cache_key] - } - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - if {[string first \$\{ $optionspecs] > 0} { - set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } - } else { - #we are always doing our first subst during the define.. shouldn't it be a separate resolve somehow? optionally so at least? - - if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { - set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel 1 [list ::subst $param]] - } - } else { - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) - if {[string first \$\{ $optionspecs] > 0} { - set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel 1 [list ::subst $param]] - } - tcl::dict::set argdefcache_unresolved $cache_key $pt_params - } - } - #argdata_cache should be limited in some fashion or will be a big memory leak??? - if {[tcl::dict::exists $argdata_cache $optionspecs]} { - #resolved cache version exists - return [tcl::dict::get $argdata_cache $optionspecs] - } - } - - - - #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices - #default to 1 for convenience - - #checks with no default - #-minsize -maxsize -range - - - #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi - #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist - set opt_required [list] - set val_required [list] - - set opt_defaults [tcl::dict::create] - - set val_defaults [tcl::dict::create] - set opt_solos [list] - #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end - - set records [list] - set linebuild "" - - set linelist [split $optionspecs \n] - set lastindent "" - foreach ln $linelist { - if {[tcl::string::trim $ln] eq ""} {continue} - regexp {(\s*).*} $ln _all lastindent - break ;#break at first non-empty - } - #puts "indent1:[ansistring VIEW $lastindent]" - set in_record 0 - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - foreach rawline $linelist { - set recordsofar [tcl::string::cat $linebuild $rawline] - #ansi colours can stop info complete from working (contain square brackets) - #review - when exactly are ansi codes allowed/expected in record lines. - # - we might reasonably expect them in default values or choices or help strings - # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. - # - eg set line "set x \"a[a+ red]red[a]\"" - # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket - if {$has_punkansi} { - set test_complete [punk::ansi::ansistrip $recordsofar] - } else { - #review - #we only need to strip enough to stop interference with 'info complete' - set test_complete [string map [list \x1b\[ ""] $recordsofar] - } - if {![tcl::info::complete $test_complete]} { - #append linebuild [string trimleft $rawline] \n - if {$in_record} { - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. - #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. - #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. - #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) - #(note string first "" $str is fast and returns -1) - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline \n - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline \n - } else { - append linebuild $rawline \n - } - } else { - set in_record 1 - regexp {(\s*).*} $rawline _all lastindent - #puts "indent: [ansistring VIEW -lf 1 $lastindent]" - #puts "indent from rawline:$rawline " - append linebuild $rawline \n - } - } else { - set in_record 0 - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline - } else { - append linebuild $rawline - } - lappend records $linebuild - set linebuild "" - } - } - set cmd_info {} - set package_info {} - set id_info {} ;#e.g -children ?? - set doc_info {} - set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table - set seealso_info {} - set keywords_info {} - ###set leader_min 0 - ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit - #set leader_max "" - #(common case of no leaders specified) - set opt_any 0 - set val_min 0 - set val_max -1 ;#-1 for no limit - set DEF_definition_id $id - - #form_defs - set F [dict create _default [New_command_form _default]] - set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under - - #set ARGSPACE [dict create] ;#keyed on form - #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values - - set refs [dict create] - set record_type "" - set record_number -1 ;# - foreach rec $records { - set trimrec [tcl::string::trim $rec] - switch -- [tcl::string::index $trimrec 0] { - "" - # {continue} - } - incr record_number - set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict - if {[llength $record_values] % 2 != 0} { - #todo - avoid raising an error - store invalid defs keyed on id - error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" - } - # ---------------------------------------------------------- - # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. - #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! - #(form_ids_active is otherwise set in the @form handling block) - - #consider the following 2 line entry which is potentially dynamically included via a tstr: - # @form -form {* newform} - # @form -form {newform} -synopsis "cmd help ?stuff?" - #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. - #(because _default is usually 'taken over' by the first encountered form id) - #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record - #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. - - if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { - set patterns [dict get $record_values -form] - set record_form_ids [list] - foreach p $patterns { - if {[regexp {[*?\[\]]} $p]} { - #isglob - only used for matching existing forms - lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] - } else { - #don't test for existence - will define new form if necessary - lappend record_form_ids $p - } - } - #-form values could be globs that didn't match. record_form_ids could be empty.. - if {[llength $record_form_ids]} { - #only rename _default if it's the sole entry - if {[dict size $F] == 1 && [dict exists $F "_default"]} { - if {"_default" ni $record_form_ids} { - #only initial form exists - but we are mentioning new ones - #first rename the _default to first encountered new form id - #(just replace whole dict with new key - same data) - set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] - #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F - #we are only setting active because of the rename - @form is the way to change active forms list - set form_ids_active [lindex $record_form_ids 0] - } - } - foreach fid $record_form_ids { - if {![dict exists $F $fid]} { - if {$firstword eq "@form"} { - #only @form directly supplies keys - dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] - } else { - dict set F $fid [New_command_form $fid] - } - } else { - #update form with current record opts, except -form - if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } - } - } - } - } else { - #missing or empty -form - set record_form_ids $form_ids_active - if {$firstword eq "@form"} { - foreach fid $form_ids_active { - dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] - } - } - } - # ---------------------------------------------------------- - - set firstchar [tcl::string::index $firstword 0] - set secondchar [tcl::string::index $firstword 1] - if {$firstchar eq "@" && $secondchar ne "@"} { - set record_type "directive" - set directive_name $firstword - set at_specs $record_values - - switch -- [tcl::string::range $directive_name 1 end] { - dynamic { - set is_dynamic 1 - } - id { - #disallow duplicate @id line ? - #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) - - #id An id will be allocated if no id line present or the -id value is "auto" - - if {[dict exists $at_specs -id]} { - set thisid [dict get $at_specs -id] - if {$thisid ni [list $id auto]} { - error "punk::args::define @id mismatch existing: $id vs $thisid" - } - } - set id_info $at_specs - } - ref { - #a reference within the definition - #e.g see punk::args::tclcore ::after - #global reference dict - independent of forms - #ignore refs without an -id - #store all keys except -id - #complete overwrite if refid repeated later on - if {[dict exists $at_specs -id]} { - dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] - } - } - default { - #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple - #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) - #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) - #That is possibly too complicated and/or unnecessary? - #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? - - if {[dict exists $at_specs -id]} { - set copyfrom [get_spec [dict get $at_specs -id]] - #we don't copy the @id info from the source - #for now we only copy across if nothing set.. - #todo - bring across defaults for empty keys at targets? - #need to keep it simple enough to reason about behaviour easily.. - if {[dict size $copyfrom]} { - if {![dict size $cmd_info]} { - set cmd_info [dict get $copyfrom cmd_info] - } - if {![dict size $doc_info]} { - set doc_info [dict get $copyfrom doc_info] - } - foreach fid $record_form_ids { - #only use elements with matching form id? - #probably this feature mainly useful for _default anyway so that should be ok - #cooperative doc sets specified in same file could share via known form ids too - #todo argdisplay_info by fid - if {![dict size $argdisplay_info]} { - set argdisplay_info [dict get $copyfrom argdisplay_info] - } - #TODO - #create leaders opts vals depending on position of @default line? - #options on @default line to exclude/include sets??? - } - } - } - } - form { - # arity system ? - #handle multiple parsing styles based on arities and keyword positions (and/or flags?) - #e.g see lseq manual with 3 different parsing styles. - #aim to produce a table/subtable for each - # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ - # -arities { - # 2 - # {3 anykeys {1 .. 1 to}} - # {4 anykeys {3 by}} - # {5 anykeys {1 .. 1 to 3 by}} - # }\ - # -fallback 1 - # ... - # @parser -synopsis "start 'count' count ??'by'? step?"\ - # -arities { - # {3 anykeys {1 count}} - # } - # ... - # @form -synopsis "count ?'by' step?"\ - # -arities { - # 1 - # {3 anykeys {1 by}} - # } - # - # see also after manual - # @form -arities {1} - # @form -arities { - # 1 anykeys {0 info} - # } - #todo - - #can we generate a form synopsis if -synopsis not supplied? - - #form id can be list of ints|names?, or * - if {[dict exists $at_specs -form]} { - set idlist [dict get $at_specs -form] - if {$idlist eq "*"} { - #* only applies to form ids that exist at the time - set idlist [dict keys $F] - } - set form_ids_active $idlist - } - #new form keys already created if they were needed (done for all records that have -form ) - } - package { - set package_info [dict merge $package_info $at_specs] - } - cmd { - #allow arbitrary - review - set cmd_info [dict merge $cmd_info $at_specs] - } - doc { - set doc_info [dict merge $doc_info $at_specs] - } - argdisplay { - #override the displayed argument table. - #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing - set argdisplay_info [dict merge $argdisplay_info $at_specs] - } - opts { - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "values"} { - error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" - } - dict set F $fid argspace "options" - set tmp_optspec_defaults [dict get $F $fid optspec_defaults] - - foreach {k v} $at_specs { - switch -- $k { - -any - - -anyopts { - set opt_any $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { - #review - only apply to certain types? - tcl::dict::set tmp_optspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_optspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - none - "" - - - any - ansistring - globstring - list { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_optspec_defaults -type $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - #allow overriding of defaults for options that occur later - tcl::dict::set tmp_optspec_defaults $k $v - } - default { - set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" - } - } - } - dict set F $fid optspec_defaults $tmp_optspec_defaults - } ;# end foreach record_form_ids - } - leaders { - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] in [list options values]} { - error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" - } - set tmp_leaderspec_defaults [dict get $F $fid leaderspec_defaults] - - foreach {k v} $at_specs { - switch -- $k { - -min - - -minvalues { - if {$v < 0} { - error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MIN $v - #if {$leader_max == 0} { - # set leader_max -1 - #} - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MAX $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -choiceinfo { - if {[llength $v] %2 != 0} { - error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - #-choicegroups? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_leaderspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set tmp_leaderspec_defaults $k $v - } - default { - set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid leaderspec_defaults $tmp_leaderspec_defaults - - } ;#end foreach record_form_ids - - } - values { - foreach fid $record_form_ids { - dict set F $fid argspace "values" - - set tmp_valspec_defaults [dict get $F $fid valspec_defaults] - - foreach {k v} $at_specs { - switch -- $k { - -form { - } - -min - - -minvalues { - if {$v < 0} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" - } - set val_min $v - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" - } - set val_max $v - } - -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_valspec_defaults $k $v - } - -choiceinfo - -choicegroups { - if {[llength $v] % 2 != 0} { - error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - # -choicegroups ?? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_valspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set tmp_valspec_defaults $k $v - } - default { - set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid valspec_defaults $tmp_valspec_defaults - } - - } - seealso { - #todo! - #like @doc, except displays in footer, multiple - sub-table? - set seealso_info [dict merge $seealso_info $at_specs] - } - keywords { - #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? - set keywords_info [dict merge $keywords_info $at_specs] - } - default { - error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @argdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" - } - } - #record_type directive - continue - } elseif {$firstchar eq "-"} { - set argname $firstword - set argdef_values $record_values - tcl::dict::set argdef_values -ARGTYPE option - - - - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - dict set F $fid argspace "options" - } elseif {[dict get $F $fid argspace] eq "values"} { - error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" - } - set record_type option - dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] - #lappend opt_names $argname - } - - set is_opt 1 - } else { - set argname $firstword - if {$firstchar eq "@"} { - #allow basic @@ escaping for literal argname that begins with @ - set argname [tcl::string::range $argname 1 end] - } - - set argdef_values $record_values - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - set record_type leader - tcl::dict::set argdef_values -ARGTYPE leader - #lappend leader_names $argname - set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] - if {$argname ni $temp_leadernames} { - lappend temp_leadernames $argname - tcl::dict::set F $fid LEADER_NAMES $temp_leadernames - } else { - error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" - } - - if {[dict get $F $fid LEADER_MAX] >= 0} { - dict set F $fid LEADER_MAX [llength $temp_leadernames] - } - } else { - set record_type value - tcl::dict::set argdef_values -ARGTYPE value - set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] - lappend temp_valnames $argname - tcl::dict::set F $fid VAL_NAMES $temp_valnames - #lappend val_names $argname - } - } - - set is_opt 0 - } - - - #assert - we only get here if it is a value or flag specification line. - #assert argdef_values has been set to the value of record_values - - foreach fid $record_form_ids { - if {$is_opt} { - set spec_merged [dict get $F $fid optspec_defaults] - } else { - if {[dict get $F $fid argspace] eq "values"} { - set spec_merged [dict get $F $fid valspec_defaults] - } else { - set spec_merged [dict get $F $fid leaderspec_defaults] - } - } - - # -> argopt argval - foreach {spec specval} $argdef_values { - #literal-key switch - bytecompiled to jumpTable - switch -- $spec { - -form { - - } - -type { - #normalize here so we don't have to test during actual args parsing in main function - switch -- [tcl::string::tolower $specval] { - int - integer { - tcl::dict::set spec_merged -type int - } - bool - boolean { - tcl::dict::set spec_merged -type bool - } - char - character { - tcl::dict::set spec_merged -type char - } - dict - dictionary { - tcl::dict::set spec_merged -type dict - } - "" - none { - if {$is_opt} { - tcl::dict::set spec_merged -type none - 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 - error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" - } - } - any - anything { - tcl::dict::set spec_merged -type any - } - ansi - ansistring { - tcl::dict::set spec_merged -type ansistring - } - any - string - globstring { - tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - } - default { - #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW - tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - } - } - } - -default - -solo - -range - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo - - -minsize - -maxsize - -nocase - -optional - -multiple - - -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - - -regexprepass - -regexprefail - -regexprefailmsg - { - #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines - #review -solo 1 vs -type none ? conflicting values? - tcl::dict::set spec_merged $spec $specval - } - -validationtransform { - #string is dict only 8.7/9+ - if {[llength $specval] % 2} { - error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" - } - dict for {tk tv} $specval { - switch -- $tk { - -function - -type - -minsize - -maxsize - -range { - } - default { - set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? - error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" - } - } - } - - } - default { - if {[string match ref-* $spec]} { - #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) - #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. - if {![tcl::dict::exists $refs $specval]} { - puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" - } else { - set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" - if {$targetswitch eq "-*"} { - set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id - } else { - if {[tcl::dict::exists $refs $specval $targetswitch]} { - tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] - } else { - puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" - } - } - } - } else { - set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - ] - error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" - } - } - } - } ;# end foreach {spec specval} argdef_values - - - if {$is_opt} { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } else { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - tcl::dict::set F $fid ARG_INFO $argname $spec_merged - #review existence of -default overriding -optional - if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { - if {$is_opt} { - lappend opt_required $argname - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - set temp_leader_required [dict get $F $fid LEADER_REQUIRED] - lappend temp_leader_required $argname - dict set F $fid LEADER_REQUIRED $temp_leader_required - #lappend leader_required $argname - } else { - lappend val_required $argname - } - } - } - if {[tcl::dict::exists $spec_merged -default]} { - if {$is_opt} { - tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } else { - tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] - } - } - } - } ;# end foreach fid record_form_ids - - } ;# end foreach rec $records - - - #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { - # variable id_counter - # set DEF_definition_id "autoid_[incr id_counter]" - #} - - - #check ALL forms not just form_ids_active (record_form_ids) - dict for {fid formdata} $F { - # REVIEW - #no values specified - we can allow last leader to be multiple - foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { - error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" - } - } - #confirm any valnames before last don't have -multiple key - foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { - error "bad key -multiple on argument spec for value '$valname' in command form:'$fid'. Only the last value argument specification can be marked -multiple @id:$DEF_definition_id" - } - } - - #todo - document that ambiguities in API are likely if both @leaders and @values used - #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) - - - dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - - - - - #todo - precalculate a set of 'arity' entries for each form - #We want a structure for the arg parser to get easy access and make a fast decision on which form applies - #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? - #1) after ms (1 1) - #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? - #3) after cancel id (2 2) - #4) after cancel script ?script...? (2 -1) - #5) after idle script ?script...? (1 -1) - #6) after info ?id? (1 2) - - #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) - - #in the above case we have no unique total_arity - #we would also want to consider values when selecting - #e.g given the invalid command "after cancel" - # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. - - - - set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands - #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use - #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form - #e.g commandline completion could show list of synopsis entries to select from - - set form_info [dict create] - dict for {fid fdict} $F { - dict set form_info $fid {} - dict for {optk optv} $fdict { - if {[string match -* $optk]} { - dict set form_info $fid $optk $optv - } - } - } - - set argdata_dict [tcl::dict::create\ - id $DEF_definition_id\ - ARG_INFO [dict get $F $firstformid ARG_INFO]\ - ARG_CHECKS [dict get $F $firstformid ARG_CHECKS]\ - LEADER_DEFAULTS [dict get $F $firstformid LEADER_DEFAULTS]\ - LEADER_REQUIRED [dict get $F $firstformid LEADER_REQUIRED]\ - LEADER_NAMES [dict get $F $firstformid LEADER_NAMES]\ - LEADER_MIN [dict get $F $firstformid LEADER_MIN]\ - LEADER_MAX [dict get $F $firstformid LEADER_MAX]\ - leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ - LEADER_CHECKS_DEFAULTS [dict get $F $firstformid LEADER_CHECKS_DEFAULTS]\ - opt_defaults $opt_defaults\ - opt_required $opt_required\ - OPT_NAMES [dict get $F $firstformid OPT_NAMES]\ - opt_any $opt_any\ - opt_solos $opt_solos\ - optspec_defaults [dict get $F $firstformid optspec_defaults]\ - OPT_CHECKS_DEFAULTS [dict get $F $firstformid OPT_CHECKS_DEFAULTS]\ - val_defaults $val_defaults\ - val_required $val_required\ - VAL_NAMES [dict get $F $firstformid VAL_NAMES]\ - val_min $val_min\ - val_max $val_max\ - valspec_defaults [dict get $F $firstformid valspec_defaults]\ - VAL_CHECKS_DEFAULTS [dict get $F $firstformid VAL_CHECKS_DEFAULTS]\ - cmd_info $cmd_info\ - doc_info $doc_info\ - package_info $package_info\ - argdisplay_info $argdisplay_info\ - seealso_info $seealso_info\ - id_info $id_info\ - FORMS $F\ - form_names [dict keys $F]\ - FORM_INFO $form_info\ - ] - - tcl::dict::set argdata_cache $cache_key $argdata_dict - if {$is_dynamic} { - #also cache resolved version - tcl::dict::set argdata_cache $optionspecs $argdata_dict - } - - #tcl::dict::set id_cache_rawdef $DEF_definition_id $args - #puts "xxx:$result" - return $argdata_dict - } - - #return raw definition list as created with 'define' - # - possibly with unresolved dynamic parts - proc raw_def {id} { - variable id_cache_rawdef - set realid [real_id $id] - if {![dict exists $id_cache_rawdef $realid]} { - return "" - } - return [tcl::dict::get $id_cache_rawdef $realid] - } - - - namespace eval argdoc { - variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @argdisplay @seealso @leaders @opts @values leaders opts values} - variable resolved_def_TYPE_CHOICEGROUPS { - directives {@id @package @cmd @ref @doc @argdisplay @seealso} - argumenttypes {leaders opts values} - remaining_defaults {@leaders @opts @values} - } - - lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { - @id -id ::punk::args::resolved_def - @cmd -name punk::args::resolved_def -help\ - "Resolves or retrieves the previously resolved definition and - uses the 'spec' form to build a response in definition format. - - Pulling argument definition data from another function is a form - of tight coupling to the other function that should be done with - care. - - Note that the directives @leaders @opts @values may appear multiple - times in a source definition - applying defaults for arguments that - follow. When retrieving these - there is only a single result for - each that represents the defaults after all have been applied. - When retrieving -types * each of these will be positioned before - the arguments of that type - but this doesn't mean there was a single - leading directive for this argument type in the source definition. - Each argument has already had its complete specification recorded in - its own result. - - When manually specifying -types, the order @leaders then @opts then - @values must be maintained - but if they are placed before their - corresponding arguments, they will not affect the retrieved arguments - as these arguments are already fully spec'd. The defaults from the - source can be removed by adding @leaders, @opts @values to the - -antiglobs list, but again - this won't affect the existing arguments. - Each argument can have members of its spec overridden using the - -override dictionary. - " - @leaders -min 0 -max 0 - @opts - -return -default text -choices {text dict} - -form -default 0 -help\ - "Ordinal index or name of command form" - - #no restriction on number of types/repetitions? - -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} - -antiglobs -default {} -type list -help\ - "Glob patterns for directive or argument/flags to - be suppressed" - -override -type dict -optional 1 -default "" -help\ - "dict of dicts. Key in outer dict is the name of a - directive or an argument. Inner dict is a map of - overrides/additions (- ...) for that line. - " - @values -min 1 -max -1 - id -type string -help\ - "identifer for a punk::args definition - This will usually be a fully-qualifed - path for a command name" - pattern -type string -optional 1 -default * -multiple 1 -help\ - "glob-style patterns for retrieving value or switch - definitions. - - If -type is * and pattern is * the entire definition including - directive lines will be returned in line form. - (directives are lines beginning with - @ e.g @id, @cmd etc) - - if -type is leaders,opts or values matches from that type - will be returned. - - if -type is another directive such as @id, @doc etc the - patterns are ignored. - - " - }]] - } - - - proc resolved_def {args} { - #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. - set opts [dict create\ - -return text\ - -types {}\ - -form 0\ - -antiglobs {}\ - -override {}\ - ] - if {[llength $args] < 1} { - #must have at least id - punk::args::parse $args withid ::punk::args::resolved_def - return - } - set patterns [list] - - #a definition id must not begin with "-" ??? review - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {$a in {-type -types}} { - incr i - dict set opts -types [lindex $args $i] - } elseif {[string match -* $a]} { - incr i - dict set opts $a [lindex $args $i] - } else { - set id [lindex $args $i] - set patterns [lrange $args $i+1 end] - break - } - if {$i == [llength $args]-1} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - if {![llength $patterns]} { - set patterns [list *] - } - dict for {k v} $opts { - switch -- $k { - -return - -form - -types - -antiglobs - -override {} - default { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - } - set typelist [dict get $opts -types] - if {[llength $typelist] == 0} { - set typelist {*} - } - foreach type $typelist { - if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - - - variable id_cache_rawdef - set realid [real_id $id] - if {$realid eq ""} { - return - } - - set deflist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] - - set opt_form [dict get $opts -form] - if {[string is integer -strict $opt_form]} { - set formname [lindex [dict get $specdict form_names] $opt_form] - } else { - set formname $opt_form - } - set opt_override [dict get $opts -override] - set opt_return [dict get $opts -return] - - #set arg_info [dict get $specdict ARG_INFO] - set arg_info [dict get $specdict FORMS $formname ARG_INFO] - set argtypes [dict create leaders leader opts option values value] - - set opt_antiglobs [dict get $opts -antiglobs] - set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] - set suppressed_directives [list] - set suppressed_args [list] - foreach ag $opt_antiglobs { - foreach d $directives { - if {[string match $ag $d]} { - lappend suppressed_directives $d - } - } - foreach argname [dict keys $arg_info] { - if {[string match $ag $argname]} { - lappend suppressed_args $argname - } - } - } - set suppressed_directives [lsort -unique $suppressed_directives] - set suppressed_args [lsort -unique $suppressed_args] - - set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] - - set globbed [list] - foreach pat $patterns { - set matches [dict keys $arg_info $pat] - lappend globbed {*}$matches - } - set globbed [lsort -unique $globbed] - set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args] - - set result "" - set resultdict [dict create] - foreach type $typelist { - switch -exact -- $type { - * { - if {"@id" in $included_directives} { - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - foreach directive {@package @cmd @doc @seealso @argdisplay} { - set dshort [string range $directive 1 end] - if {"$directive" in $included_directives} { - if {[dict exists $opt_override $directive]} { - append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict ${dshort}_info]" - dict set resultdict $directive [dict get $specdict ${dshort}_info] - } - } - } - #output ordered by leader, option, value - foreach pseudodirective {leaders opts values} tp {leader option value} { - set directive "@$pseudodirective" - switch -- $directive { - @leaders {set defaults_key leaderspec_defaults} - @opts {set defaults_key optspec_defaults} - @values {set defaults_key valspec_defaults} - } - - if {"$directive" in $included_directives} { - if {[dict exists $opt_override "$directive"]} { - append result \n "$directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict $defaults_key]" - dict set resultdict $directive [dict get $specdict $defaults_key] - } - } - - if {$pseudodirective in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq $tp} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "$m $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - - } - @id { - if {"@id" in $included_directives} { - #only a single id record can exist - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - } - @package - @cmd - @doc - @seealso - @argdisplay { - if {"$type" in $included_directives} { - set tp [string range $type 1 end] ;# @package -> package - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict ${tp}_info]" - dict set resultdict $type [dict get $specdict ${tp}_info] - } - } - } - @leaders - @opts - @values { - #these are the active defaults for further arguments - if {"$type" in $included_directives} { - switch -- $type { - @leaders {set defaults_key leaderspec_defaults} - @opts {set defaults_key optspec_defaults} - @values {set defaults_key valspec_defaults} - } - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict leaderspec_defaults]" - dict set resultdict $type [dict get $specdict leaderspec_defaults] - } - } - } - leaders - opts - values { - #pseudo-directives - if {$type in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "$m $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - default { - } - } - if {$opt_return eq "text"} { - return $result - } else { - return $resultdict - } - } - } - - proc resolved_def_values {id {patternlist *}} { - variable id_cache_rawdef - set realid [real_id $id] - if {$realid ne ""} { - set speclist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [resolve {*}$speclist] - set arg_info [dict get $specdict ARG_INFO] - set valnames [dict get $specdict VAL_NAMES] - set result "" - if {$patternlist eq "*"} { - foreach v $valnames { - set def [dict get $arg_info $v] - set def [dict remove $def -ARGTYPE] - append result \n "$v $def" - } - return $result - } else { - foreach pat $patternlist { - set matches [dict keys $arg_info $pat] - set matches [lsearch -all -inline -glob $valnames $pat] - foreach m $matches { - set def [dict get $arg_info $m] - set def [dict remove $def -ARGTYPE] - append result \n "$m $def" - } - } - return $result - } - } - } - #proc resolved_def_leaders ?? - #proc resolved_def_opts ?? - - proc get_spec {id} { - set rdef [raw_def $id] - if {$rdef eq ""} {return} - return [resolve {*}$rdef] - #if {[id_exists $id]} { - # return [resolve {*}[raw_def $id]] - #} - } - proc is_dynamic {id} { - variable id_cache_rawdef - variable rawdef_cache - set deflist [raw_def $id] - if {[dict exists $rawdef_cache $deflist -dynamic]} { - return [dict get $rawdef_cache $deflist -dynamic] - } - return [rawdef_is_dynamic $deflist] - #@dynamic only has meaning as 1st element of a def in the deflist - } - - #@id must be within first 4 lines of a block - or assign auto - #review - @dynamic block where -id not explicitly set? - disallow? - proc rawdef_id {rawdef} { - set id "" - foreach d $rawdef { - foreach ln [lrange [split $d \n] 0 4] { - if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { - if {$firstword eq "@id"} { - if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { - set id [dict get $rest -id] - break - } - } - } - } - if {$id ne ""} { - break - } - } - if {$id eq "" || [string tolower $id] eq "auto"} { - variable id_counter - set id "autoid_[incr id_counter]" - } - #puts "==>id: $id" - return $id - } - #test the rawdef for @dynamic directive - proc rawdef_is_dynamic {rawdef} { - #temporary - old way - set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] - if {$flagged_dynamic} { - return true - } - foreach d $rawdef { - if {[regexp {\s*(\S+)} $d _match firstword]} { - if {$firstword eq "@dynamic"} { - return true - } - } - } - return false - } - - variable aliases - set aliases [dict create] - - lappend PUNKARGS [list { - @id -id ::punk::args::get_ids - @cmd -name punk::args::get_ids -help\ - "return list of ids for argument definitions" - @values -min 0 -max 1 - match -default * -help\ - "exact id or glob pattern for ids" - }] - proc get_ids {{match *}} { - variable id_cache_rawdef - variable aliases - return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] - } - - #we don't automatically test for (autodef)$id - only direct ids and aliases - proc id_exists {id} { - variable aliases - if {[tcl::dict::exists $aliases $id]} { - return 1 - } - variable id_cache_rawdef - tcl::dict::exists $id_cache_rawdef $id - } - proc set_alias {alias id} { - variable aliases - dict set aliases $alias $id - } - proc unset_alias {alias} { - variable aliases - dict unset aliases $alias - } - proc get_alias {alias} { - variable aliases - if {[dict exists $aliases $alias]} { - return [tcl::dict::get $aliases $alias] - } - } - - proc real_id {id} { - variable id_cache_rawdef - variable aliases - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } else { - set check_updates [list [namespace qualifiers $id]] - if {![llength [update_definitions $check_updates]]} { - #nothing new loaded - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } else { - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } - } - } - - proc status {} { - upvar ::punk::args::register::NAMESPACES registered - upvar ::punk::args::register::loaded_packages loaded_packages - upvar ::punk::args::register::loaded_info loaded_info - upvar ::punk::args::register::scanned_packages scanned_packages - upvar ::punk::args::register::scanned_info scanned_info - set result "" - # [format %-${w0}s $idtail] - set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] - append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n - set width_c2 [string length "Scanned_ids"] - set width_c3 [string length "Scantime_us"] - set width_c4 [string length "Loaded_defs"] - set width_c5 [string length "Loadtime_us"] - set count_unloaded 0 - set count_loaded 0 - foreach ns $registered { - if {$ns in $scanned_packages} { - set ids [dict get $scanned_info $ns idcount] - set scan_us [dict get $scanned_info $ns time] - } else { - set ids "" - set scan_us "" - } - if {$ns in $loaded_packages} { - incr count_loaded - set ldefs [dict get $loaded_info $ns defcount] - set load_us [dict get $loaded_info $ns time] - } else { - incr count_unloaded - set ldefs "" - set load_us "" - } - append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n - } - append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" - return $result - } - - #scanned_packages (list) - #namespace_docpackages (dict) - proc update_definitions {{nslist *}} { - if {[set gposn [lsearch $nslist {}]] >= 0} { - lset nslist $gposn :: - } - upvar ::punk::args::register::NAMESPACES registered ;#list - upvar ::punk::args::register::loaded_packages loaded_packages ;#list - upvar ::punk::args::register::loaded_info loaded_info ;#dict - upvar ::punk::args::register::scanned_packages scanned_packages ;#list - upvar ::punk::args::register::scanned_info scanned_info ;#dict - upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict - - - #puts stderr "-->update_definitions '$nslist'" - #needs to run quickly - especially when no package namespaces to be scanned for argdefs - #e.g - gets called for each subcommand of an ensemble (could be many) - # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. - #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. - # -- --- --- --- --- --- - # common-case fast-path - - if {[llength $loaded_packages] == [llength $registered]} { - #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. - #assert - if all are registered - then all have been scanned ( - return {} - } - # -- --- --- --- --- --- - - set unscanned [punklib_ldiff $registered $scanned_packages] - if {[llength $unscanned]} { - foreach pkgns $unscanned { - set idcount 0 - set ts_start [clock microseconds] - if {[info exists ${pkgns}::PUNKARGS]} { - set seen_documentedns [list] ;#seen per pkgns - foreach definitionlist [set ${pkgns}::PUNKARGS] { - #namespace eval $evalns [list punk::args::define {*}$definitionlist] - set id [rawdef_id $definitionlist] - if {[string match autoid_* $id]} { - puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" - puts stderr "definition:\n" - foreach d $definitionlist { - set out "" - foreach ln [split $d \n] { - append out " " $ln \n - } - puts $out - } - continue - } - #todo - detect duplicate ids (last will silently win.. should be reported somewhere) - incr idcount - set documentedns [namespace qualifiers $id] - if {$documentedns eq ""} {set documentedns ::} - if {$documentedns ni $seen_documentedns} { - #don't add own ns as a key in namespace_docpackages - if {$documentedns ne $pkgns} { - dict lappend namespace_docpackages $documentedns $pkgns - } - lappend seen_documentedns $documentedns - } - } - } - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - dict set scanned_info $pkgns [dict create time $diff idcount $idcount] - #we count it as scanned even if PUNKARGS didn't exist - #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) - lappend scanned_packages $pkgns - } - } - - - - if {"*" in $nslist} { - set needed [punklib_ldiff $registered $loaded_packages] - } else { - set needed [list] - foreach pkgns $nslist { - if {$pkgns in $registered && $pkgns ni $loaded_packages} { - lappend needed $pkgns - } - #argdoc sub namespace is a standard place to put defs that match the namespace below - #(generally the PUNKARGS in a namespace should apply to own ns) - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { - lappend needed $docns - } - } - if {[dict exists $namespace_docpackages $pkgns]} { - #this namespace has other argdef sources - foreach docns [dict get $namespace_docpackages $pkgns] { - if {$docns ni $loaded_packages} { - lappend needed $docns - } - } - } - } - } - - - - set newloaded [list] - foreach pkgns $needed { - #puts stderr "update_definitions Loading: $pkgns" - set ts_start [clock microseconds] - set def_count 0 - if {![catch { - if {[info exists ${pkgns}::PUNKARGS]} { - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - namespace eval ${pkgns}::argdoc { - set epath [namespace path] - set pkgns [namespace parent] - if {$pkgns ni $epath} { - namespace path [list {*}$epath $pkgns] ;#add to tail - } - - } - set evalns $docns - } else { - set evalns $pkgns - } - foreach definitionlist [set ${pkgns}::PUNKARGS] { - namespace eval $evalns [list punk::args::define {*}$definitionlist] - incr def_count - } - } - - #process list of 2-element lists - if {[info exists ${pkgns}::PUNKARGS_aliases]} { - foreach adef [set ${pkgns}::PUNKARGS_aliases] { - punk::args::set_alias {*}$adef - } - } - } errMsg]} { - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - lappend loaded_packages $pkgns - lappend newloaded $pkgns - dict set loaded_info $pkgns [dict create time $diff defcount $def_count] - } else { - puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" - } - } - return $newloaded - } - - #for use within get_dict only - #This mechanism gets less-than-useful results for oo methods - #e.g {$obj} - proc Get_caller {} { - #set call_level -3 ;#for get_dict call - set call_level -4 - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - #puts "-->$cmdinfo" - #puts "-->[tcl::info::frame -3]" - while {[string last \n $cmdinfo] >= 1} { - #looks like a script - haven't gone up far enough? - #(e.g patternpunk oo system: >punk . poses -invalidoption) - incr call_level -1 - if {[catch { - set nextup [tcl::info::frame $call_level] - } ]} { - break - } - set cmdinfo [tcl::dict::get $nextup cmd] - set caller [regexp -inline {\S+} $cmdinfo] - if {[interp alias {} $caller] ne ""} { - #puts "found alias for caller $caller to [interp alias {} $caller]" - #see if we can go further - incr call_level -1 - if {[catch { - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - } errM ]} { - puts "err: $errM" - break - } - } - } - set caller [regexp -inline {\S+} $cmdinfo] - if {$caller eq "namespace"} { - # review - message? - set cmdinfo "punk::args::get_dict called from namespace" - } - return $cmdinfo - } - - - # -------------------------------------- - #test of Get_caller - lappend PUNKARGS [list { - @id -id ::punk::args::test1 - @values -min 0 -max 0 - }] - proc test_get_dict {args} { - punk::args::get_dict {*}[punk::args::raw_def ::punk::args::test1] $args - } - proc test_get_by_id {args} { - punk::args::get_by_id ::punk::args::test1 $args - } - #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. - proc test_callers {args} { - if {![llength $args]} { - puts "these test functions accept no arguments" - puts "Call with arg(s) to compare error output" - } - - if {[catch {test_get_dict {*}$args} errM]} { - puts $errM - } - puts "------------" - if {[catch {test_get_by_id {*}$args} errM]} { - puts $errM - } - return done - } - # -------------------------------------- - - set map "" - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::arg_error - @cmd -name punk::args::arg_error -help\ - "Generates a table (by default) of usage information for a command. - A trie system is used to create highlighted prefixes for command - switches and for subcommands or argument/switch values that accept - a defined set of choices. These prefixes match the mechanism used - to validate arguments (based on tcl::prefix::match). - - This function is called during the argument parsing process - (if the definition is not only being used for documentation) - It is also called by punk::args::usage which is in turn - called by the punk::ns introspection facilities which creates - on the fly definitions for some commands such as ensembles and - oo objects where a manually defined one isn't present. - " - @leaders -min 2 -max 2 - msg -type string -help\ - "Error message to display immediately prior to usage table. - May be empty string to just display usage. - " - spec_dict -type dict -help\ - "Dictionary of argument specifications. - This is the internal format parsed from - the textual definition. It contains the data - organised/optimised to allow the final arg - parser/validator to make decisions. - " - @opts - -badarg -type string -help\ - "name of an argument to highlight" - -aserror -type boolean -help\ - "If true, the usage table is raised as an error message, - otherwise it is returned as a value." - -return -choices {string table tableobject} -choicelabels { - string "no table layout" - tableobject "table object cmd" - table "full table laout" - } - -scheme -choices {nocolour info error} - }] ] - - #basic recursion blocker - variable arg_error_isrunning 0 - proc arg_error {msg spec_dict args} { - #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. - #accept an option here so that we can still use full output for usage requests. - #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args - #Development/experimentation may be done with full table-based error reporting - but for production release it - #may be desirable to reduce overhead on catches. - #consider per-namespace or namespace-tree configurability. - #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due - #to resource availability etc - so the slower error generation time may not always be a problem. - #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling - #code which has no use for the enhanced error info. - #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. - #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system - #todo - #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error - #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) - - #todo - document unnamed leaders and unnamed values where -min and/or -max specified - #e.g punk::args::get_dict {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} {} - #only |?-x?|string|... is shown in the output table. - #should be something like: - # |arg | - # |?-x? | - # |arg | - # |?arg...?| - # Where/how to specify counts? - #also.. - # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? - # - - - if {[catch {package require punk::ansi}]} { - proc punk::args::a {args} {} - proc punk::args::a+ {args} {} - } else { - namespace eval ::punk::args { - namespace import ::punk::ansi::a ::punk::ansi::a+ - } - } - #limit colours to standard 16 so that themes can apply to help output - variable arg_error_isrunning - if {$arg_error_isrunning} { - error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" - } - - if {[llength $args] %2 != 0} { - error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" - } - - set arg_error_isrunning 1 - - set badarg "" - set returntype table ;#table as string - set as_error 1 ;#usual case is to raise an error - set scheme error - dict for {k v} $args { - set fullk [tcl::prefix::match -error "" {-badarg -aserror -return -scheme} $k] - switch -- $fullk { - -badarg { - set badarg $v - } - -aserror { - if {![string is boolean -strict $v]} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" - } - set as_error $v - } - -scheme { - set scheme $v - } - -return { - if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" - } - set returntype $v - } - default { - set arg_error_isrunning 0 - error "arg_error invalid option $k. Known_options: -badarg -return -aserror" - } - } - } - #todo - scheme - use config and iterm toml definitions etc - switch -- $scheme { - "" - -nocolor - -nocolour { - set scheme nocolour - } - info - error {} - default { - set scheme na - } - } - #hack some basics for now. - #for coloured schemes - use bold as well as brightcolour in case colour off. - array set CLR {} - set CLR(errormsg) [a+ brightred] - set CLR(title) "" - set CLR(check) [a+ brightgreen] - set CLR(solo) [a+ brightcyan] - set CLR(choiceprefix) [a+ underline] - set CLR(badarg) [a+ brightred] - set CLR(linebase_header) [a+ white] - set CLR(cmdname) [a+ brightwhite] - set CLR(groupname) [a+ bold] - set CLR(ansiborder) [a+ bold] - set CLR(ansibase_header) [a+ bold] - set CLR(ansibase_body) [a+ white] - - switch -- $scheme { - nocolour { - set CLR(errormsg) [a+ bold] - set CLR(title) [a+ bold] - set CLR(check) "" - set CLR(solo) "" - set CLR(badarg) [a+ reverse] ;#? experiment - set CLR(cmdname) [a+ bold] - set CLR(linebase_header) "" - set CLR(linebase) "" - set CLR(ansibase_body) "" - } - info { - set CLR(errormsg) [a+ brightred bold] - set CLR(title) [a+ brightyellow bold] - set CLR(check) [a+ brightgreen bold] - set CLR(choiceprefix) [a+ brightgreen bold] - set CLR(groupname) [a+ cyan bold] - set CLR(ansiborder) [a+ brightcyan bold] - set CLR(ansibase_header) [a+ cyan] - set CLR(ansibase_body) [a+ white] - } - error { - set CLR(errormsg) [a+ brightred bold] - set CLR(title) [a+ brightcyan bold] - set CLR(check) [a+ brightgreen bold] - set CLR(choiceprefix) [a+ brightgreen bold] - set CLR(groupname) [a+ cyan bold] - set CLR(ansiborder) [a+ brightyellow bold] - set CLR(ansibase_header) [a+ yellow] - set CLR(ansibase_body) [a+ white] - } - na { - } - } - - - #set RST [a] - set RST "\x1b\[m" - set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. - - #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error - #e.g list_as_table - - # use basic colours here to support terminals without extended colours - #todo - add checks column (e.g -minsize -maxsize) - set errmsg $msg - if {![catch {package require textblock}]} { - set has_textblock 1 - } else { - set has_textblock 0 - #couldn't load textblock package - #just return the original errmsg without formatting - } - set use_table 0 - if {$has_textblock && $returntype in {table tableobject}} { - set use_table 1 - } - set errlines [list] ;#for non-textblock output - if {[catch { - if {$use_table} { - append errmsg \n - } else { - if {($returntype in {table tableobject}) && !$has_textblock} { - append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n - } else { - append errmsg \n - } - } - set cmdname [Dict_getdef $spec_dict cmd_info -name ""] - set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] - - set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] - set docurl [Dict_getdef $spec_dict doc_info -url ""] - - set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] - set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] - if {"$argdisplay_header$argdisplay_body" eq ""} { - set is_custom_argdisplay 0 - } else { - set is_custom_argdisplay 1 - } - - - set blank_header_col [list] - if {$cmdname ne ""} { - lappend blank_header_col "" - set cmdname_display $CLR(cmdname)$cmdname$RST - } else { - set cmdname_display "" - } - if {$cmdhelp ne ""} { - lappend blank_header_col "" - #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] - set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] - } else { - set cmdhelp_display "" - } - if {$docurl ne ""} { - lappend blank_header_col "" - set docurl_display [a+ white]$docurl$RST - } else { - set docurl_display "" - } - #synopsis - set synopsis "" - set form_info [dict get $spec_dict FORM_INFO] - dict for {fid finfo} $form_info { - set syn [Dict_getdef $finfo -synopsis ""] - if {$syn ne ""} { - append synopsis $syn \n - } - } - if {$synopsis ne ""} { - set synopsis [string range $synopsis 0 end-1] - lappend blank_header_col "" - } - - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - if {$use_table} { - set t [textblock::class::table new "$CLR(title)Usage$RST"] - $t add_column -headers $blank_header_col -minwidth 3 - $t add_column -headers $blank_header_col - - if {!$is_custom_argdisplay} { - lappend blank_header_col "" - #spanned columns in default argdisplay area - $t add_column -headers $blank_header_col ;#Default - $t add_column -headers $blank_header_col ;#Multi - $t add_column -headers $blank_header_col ;#Help - set arg_colspans {1 4 0 0 0} - } else { - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - set arg_colspans {1 1} - } - } - set h 0 - if {$cmdname ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] - } else { - lappend errlines "COMMAND: $cmdname_display" - } - incr h - } - if {$cmdhelp ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] - } else { - lappend errlines "Description: $cmdhelp_display" - } - incr h - } - if {$docurl ne ""} { - if {![catch {package require punk::ansi}]} { - set docurl [punk::ansi::hyperlink $docurl] - } - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] - } else { - lappend errlines "$docname $docurl_display" - } - incr h - } - if {$synopsis ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Synopsis: $synopsis] - } else { - #todo - lappend errlines "Synopsis:\n$synopsis" - } - incr h - } - - - if {$use_table} { - if {$is_custom_argdisplay} { - if {$argdisplay_header ne ""} { - $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] - } - } else { - $t configure_header $h -values {Arg Type Default Multi Help} - } - } else { - lappend errlines " --ARGUMENTS-- " - } - - if {$is_custom_argdisplay} { - if {$use_table} { - #using overall container table - #header already added - #TODO - review textblock::table features - #we can't currently span columns within the table body. - #This feature could allow hidden data columns (and sort on hidden col?) - #potentially require coordination with header colspans? - $t add_row [list "" $argdisplay_body] - } else { - if {$argdisplay_header ne ""} { - lappend errlines $argdisplay_header - } - lappend errlines {*}$argdisplay_body - } - } else { - - #set A_DEFAULT [a+ brightwhite Brightgreen] - set A_DEFAULT "" - set A_BADARG $CLR(badarg) - set greencheck $CLR(check)\u2713$RST ;#green tick - set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply - if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { - #A_PREFIX can resolve to empty string if colour off - #we then want to display underline instead - set A_PREFIX [a+ underline] - set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space - } else { - set A_PREFIXEND $RST - } - - set opt_names [list] - set opt_names_display [list] - if {[llength [dict get $spec_dict OPT_NAMES]]} { - if {![catch {package require punk::trie}]} { - set trie [punk::trie::trieclass new {*}[dict get $spec_dict OPT_NAMES]] - set idents [dict get [$trie shortest_idents ""] scanned] - #todo - check opt_prefixdeny - - $trie destroy - foreach c [dict get $spec_dict OPT_NAMES] { - set id [dict get $idents $c] - #REVIEW - if {$id eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $id] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail - #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] - lappend opt_names $c - } - } else { - set opt_names [dict get $spec_dict OPT_NAMES] - set opt_names_display $opt_names - } - } - set leading_val_names [dict get $spec_dict LEADER_NAMES] - set trailing_val_names [dict get $spec_dict VAL_NAMES] - - #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { - # if {![string match -* $argname]} { - # lappend leading_val_names [lpop trailing_val_names 0] - # } else { - # break - # } - #} - #if {![llength $leading_val_names] && ![llength $opt_names]} { - # #all vals were actually trailing - no opts - # set trailing_val_names $leading_val_names - # set leading_val_names {} - #} - set leading_val_names_display $leading_val_names - set trailing_val_names_display $trailing_val_names - - #display options first then values - foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { - lassign $argumentset argnames_display argnames - - foreach argshow $argnames_display arg $argnames { - set arginfo [dict get $spec_dict ARG_INFO $arg] - if {[dict exists $arginfo -default]} { - set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" - } else { - set default "" - } - set help [Dict_getdef $arginfo -help ""] - set allchoices_originalcase [list] - set choices [Dict_getdef $arginfo -choices {}] - set choicegroups [Dict_getdef $arginfo -choicegroups {}] - set choicemultiple [dict get $arginfo -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] - set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] - if {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - set is_multiple 1 - } else { - set multiple "" - set is_multiple 0 - } - if {[dict exists $choicegroups ""]} { - dict lappend choicegroups "" {*}$choices - } else { - set choicegroups [dict merge [dict create "" $choices] $choicegroups] - } - dict for {groupname clist} $choicegroups { - lappend allchoices_originalcase {*}$clist - } - set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] - - if {$has_choices} { - if {$help ne ""} {append help \n} - if {[dict get $arginfo -nocase]} { - set casemsg " (case insensitive)" - set allchoices_test [string tolower $allchoices_originalcase] - } else { - set casemsg " (case sensitive)" - set allchoices_test $allchoices_originalcase - } - if {[dict get $arginfo -choiceprefix]} { - set prefixmsg " (choice prefix allowed)" - } else { - set prefixmsg "" - } - set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] - set formattedchoices [dict create] ;#use dict rather than array to preserve order - append help " Choices$prefixmsg$casemsg" - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - if {$choicemultiple_max == -1} { - append help \n " The value can be a list of $choicemultiple_min or more of these choices" - } else { - if {$choicemultiple_min eq $choicemultiple_max} { - append help \n " The value must be a list of $choicemultiple_min of these choices" - } else { - append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" - } - } - } - if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set cdisplay $c - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - dict lappend formattedchoices $groupname $cdisplay - } - } - } else { - set formattedchoices $choicegroups - #set formattedchoices [dict get $arginfo -choices] - } - } else { - if {[catch { - set trie [punk::trie::trieclass new {*}$allchoices_test] - set idents [dict get [$trie shortest_idents ""] scanned] - if {[dict get $arginfo -nocase]} { - #idents were calculated on lcase - remap keys in idents to original casing - set actual_idents $idents - foreach ch $allchoices_originalcase { - if {![dict exists $idents $ch]} { - #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting - #The actual testing is done in get_dict - dict set actual_idents $ch [dict get $idents [string tolower $ch]] - } - } - set idents $actual_idents - #puts "-----" - #puts "idents $idents" - } - - $trie destroy - dict for {groupname clist} $choicegroups { - foreach c $clist { - if {$c in $choiceprefixdenylist} { - set shortestid $c - } else { - set shortestid [dict get $idents $c] - } - if {$shortestid eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $shortestid] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]" - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - dict lappend formattedchoices $groupname $cdisplay - } - } - } errM]} { - #this failure can happen if -nocase is true and there are ambiguous entries - #e.g -nocase 1 -choices {x X} - puts stderr "prefix marking failed\n$errM" - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set cdisplay $c - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - dict lappend formattedchoices $groupname $cdisplay - } - } - } else { - set formattedchoices $choicegroups - } - - } - } - set choicetable_objects [list] - set choicetable_footers [dict create] - dict for {groupname formatted} $formattedchoices { - set numcols $choicecolumns ;#todo - dynamic? - if {[llength $formatted] < $numcols} { - #don't show blank cells if single line of results - set numcols [llength $formatted] - } - if {$numcols > 0} { - if {$use_table} { - #risk of recursing - #TODO -title directly in list_as_table - set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] - lappend choicetable_objects $choicetableobj - $choicetableobj configure -title $CLR(groupname)$groupname - #append help \n[textblock::join -- " " [$choicetableobj print]] - } else { - if {$groupname ne ""} { - append help \n \n "$CLR(groupname)Group: $groupname$RST" - } else { - append help \n - } - append help \n [join $formatted \n] - } - } else { - #we were given an empty set of choices. - #probably an error in the definition - but could happen if dynamically generated. - #(e.g ensemble where unknown mechanism is used for subcommands?) - #better to just display that there were none rather than totally break the usage output. - if {$usetable} { - #these will be displayed after all table entries - if {$groupname eq ""} { - dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" - } else { - dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" - } - } else { - if {$groupname eq ""} { - append help \n " " $CLR(errormsg)(no choices defined)$RST - } else { - append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST - } - } - } - } - set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width - foreach obj $choicetable_objects { - dict lappend twidths_by_colcount [$obj column_count] [$obj width] - } - foreach obj $choicetable_objects { - set cols [$obj column_count] - set widths [dict get $twidths_by_colcount $cols] - set max [tcl::mathfunc::max {*}$widths] - $obj configure -minwidth $max ;#expand smaller ones - set i 0 - while {$i < $cols} { - #keep text aligned left on expanded tables - $obj configure_column $i -blockalign left - incr i - } - - append help \n[textblock::join -- " " [$obj print]] - #set ansititle [dict get [$obj configure -title] value] - $obj destroy - } - if {[dict size $choicetable_footers]} { - foreach groupname [dict keys $formattedchoices] { - if {[dict exists $choicetable_footers $groupname]} { - append help \n [dict get $choicetable_footers $groupname] - } - } - } - - #review. use -type to restrict additional choices - may be different to values in the -choices - if {![dict get $arginfo -choicerestricted]} { - #when -choicemultiple - the -type refers to each selection - if {[dict get $arginfo -type] eq "string"} { - append help "\n (values not in defined choices are allowed)" - } else { - append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" - } - } - } - if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { - if {$is_multiple} { - set argshow "?${argshow}...?" - } else { - set argshow "?${argshow}?" - } - } else { - if {$is_multiple} { - set argshow "${argshow}..." - } - } - set typeshow [dict get $arginfo -type] - if {$typeshow eq "none"} { - set typeshow "$typeshow $soloflag" - } - if {[dict exists $arginfo -minsize]} { - append typeshow \n "-minsize [dict get $arginfo -minsize]" - } - if {[dict exists $arginfo -maxsize]} { - append typeshow \n "-maxsize [dict get $arginfo -maxsize]" - } - if {[dict exists $arginfo -range]} { - append typeshow \n "-range [dict get $arginfo -range]" - } - - if {$use_table} { - $t add_row [list $argshow $typeshow $default $multiple $help] - if {$arg eq $badarg} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG - } - } else { - #review - formatting will be all over the shop due to newlines in typesshow, help - set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" - foreach ln [split $help \n] { - append arghelp " $ln" \n - } - lappend errlines $arghelp - } - } - } - } ;#end is_custom_argdisplay - - if {$use_table} { - $t configure -show_hseps 0\ - -show_header 1\ - -ansibase_body $CLR(ansibase_body)\ - -ansibase_header $CLR(ansibase_header)\ - -ansiborder_header $CLR(ansiborder)\ - -ansiborder_body $CLR(ansiborder) - - $t configure -maxwidth 80 ;#review - if {$returntype ne "tableobject"} { - append errmsg [$t print] - #returntype of table means just the text of the table - $t destroy - } - } else { - append errmsg [join $errlines \n] - } - } errM]} { - catch {$t destroy} - append errmsg \n - append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n - append errmsg "$errM" \n - append errmsg "$::errorInfo" - - } - set arg_error_isrunning 0 - #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. - #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) - if {$use_table} { - #assert returntype is one of table, tableobject - set result $errmsg ;#default if for some reason table couldn't be used - if {$returntype eq "tableobject"} { - if {[info object isa object $t]} { - set result $t - } - } - } else { - set result $errmsg - } - if {$as_error} { - return -code error -errorcode {TCL WRONGARGS PUNK} $result - } else { - return $result - } - } - - - lappend PUNKARGS [list { - @dynamic - @id -id ::punk::args::usage - @cmd -name punk::args::usage -help\ - "Return usage information for a command identified by an id. - - This will only work for commands where a punk::args definition exists - for the command and an id has been defined for it. The id for custom - help for a command should match the fully qualified name of the command. - - Many commands (such as ensembles and oo objects) may have argument - documentation generated dynamically and may not yet have an id. - IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. - - Generally punk::ns::arginfo (aliased as i in the punk shell) should - be used in preference - as it will search for a documentation - mechanism and call punk::args::usage as necessary. - " - -return -default table -choices {string table tableobject} - } {${[punk::args::resolved_def -types opts ::punk::args::arg_error -scheme]}} { - - @values -min 0 -max 1 - id -help\ - "Exact id. - Will usually match the command name" - }] - proc usage {args} { - lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received - set id [dict get $values id] - set real_id [real_id $id] - if {$real_id eq ""} { - error "punk::args::usage - no such id: $id" - } - arg_error "" [punk::args::get_spec $real_id] -scheme punk_info {*}$opts -aserror 0 - } - - lappend PUNKARGS [list { - @id -id ::punk::args::get_by_id - @cmd -name punk::args::get_by_id - @values -min 1 - id - arglist -type list -help\ - "list containing arguments to be parsed as per the - argument specification identified by the supplied id." - }] - - - #deprecate? - proc get_by_id {id arglist} { - set definitionlist [punk::args::raw_def $id] - if {[llength $definitionlist] == 0} { - error "punk::args::get_by_id - no such id: $id" - } - #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] - tailcall ::punk::args::get_dict {*}$definitionlist $arglist - } - - #consider - - #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) - #parse ?-flag val?... -- $arglist withid $id - #parse ?-flag val?... -- $arglist withdef $def ?$def?... - - #an experiment.. ideally we'd like arglist at the end? - #parse_withid ?-flag val?.. $id $arglist - #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? - #no possible equivalent for parse_withdef ??? - - lappend PUNKARGS [list { - @id -id ::punk::args::parse - @cmd -name punk::args::parse -help\ - "parse and validate command arguments based on a definition. - - In the 'withid' form the definition is a pre-existing record that has been - created with ::punk::args::define, or indirectly by adding a definition to - the PUNKARGS variable in a namespace which is then registered in - punk::args::register::NAMESPACES, or by a previous call to punk::parse - using 'withdef' and a definition block containing an @id -id directive. - - In the 'withdef' form - the definition is created on the first call and - cached thereafter, if the id didn't already exist. - - form1: parse $arglist ?-flag val?... withid $id - form2: parse $arglist ?-flag val?... withdef $def ?$def? - see punk::args::define" - @form -form {withid withdef} - @leaders -min 1 -max 1 - arglist -type list -optional 0 -help\ - "Arguments to parse - supplied as a single list" - - @opts - -form -type list -default * -help\ - "Restrict parsing to the set of forms listed. - Forms are the orthogonal sets of arguments a - command can take - usually described in 'synopsis' - entries." - #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance - #todo - configurable per interp/namespace - -errorstyle -type string -default enhanced -choices {enhanced standard minimal} - - @values -min 2 - - @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" - withid -type literal -help\ - "The literal value 'withid'" - id -type string -help\ - "id of punk::args definition for a command" - - - @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" - withdef -type literal -help\ - "The literal value 'withdef'" - - #todo - make -dynamic obsolete - use @dynamic directive instead - def -type string -multiple 1 -optional 0 -help\ - "Each remaining argument is a block of text - defining argument definitions. - As a special case, -dynamic may be - specified as the 1st 2 arguments. These are - treated as an indicator to punk::args about - how to process the definition." - - }] - proc parse {args} { - set tailtype "" ;#withid|withdef - if {[llength $args] < 3} { - error "punk::args::parse - invalid call. < 3 args" - } - set parseargs [lindex $args 0] - set tailargs [lrange $args 1 end] - - set split [lsearch -exact $tailargs withid] - if {$split < 0} { - set split [lsearch -exact $tailargs withdef] - if {$split < 0} { - #punk::args::usage arg_error? - error "punk::args::parse - invalid call. keyword withid|withdef required" - } else { - set tailtype withdef - } - } else { - set tailtype withid - } - - set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. - if {[llength $opts] % 2} { - error "punk::args::parse Even number of -flag val pairs required after arglist" - } - set defaultopts [dict create\ - -form {*}\ - -errorstyle enhanced\ - ] - set opts [dict merge $opts $defaultopts] - dict for {k v} $opts { - switch -- $k { - -form - -errorstyle { - } - default { - #punk::args::usage $args withid ::punk::args::parse ?? - error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" - } - } - } - switch -- $tailtype { - withid { - if {[llength [lrange $tailargs $split+1 end]] != 1} { - error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - } - set id [lindex $tailargs $split+1] - #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" - set deflist [raw_def $id] - if {[llength $deflist] == 0} { - error "punk::args::parse - no such id: $id" - } - } - withdef { - set deflist [lrange $tailargs $split+1 end] - if {[llength $deflist] < 1} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" - } - default { - error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" - } - } - try { - set result [punk::args::get_dict {*}$deflist $parseargs] - } trap {PUNKARGS VALIDATION} {msg opts} { - set opt_errorstyle [dict get $opts -errorstyle] - - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname]] $msg - #set msg "Option $argname for [Get_caller] requires type '$type'. Received: '$e'" - ##try trap? - ##return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type]]] $result - ##throw ? - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname]] $msg - #arg_error $msg $argspecs -badarg $argname - switch -- $opt_errorstyle { - minimal { - return -options [list -code error -errorcode $::errorCode] $::errorInfo - } - standard { - puts stderr "(todo enhanced error) PUNKARGS VALIDATION: $msg\n$opts" - } - enhanced { - puts stderr "(todo enhanced error) PUNKARGS VALIDATION: $msg\n$opts" - } - } - return - } trap {PUNKARGS} {msg opts} { - #trap punk::args argument validation/parsing errors and decide here - #whether to display basic error - or full usage if configured. - puts stderr "PUNKARGS OTHER: $msg\n$opts" - #JJJ - return - } trap {} {msg opts} { - #review - #puts stderr "$msg\n$opts" - #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. - #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. - throw [dict get $opts -errorcode] [dict get $opts -errorinfo] - return - } - return $result - } - proc parseXXX {args} { - #no solo flags allowed for parse function itself. (ok for arglist being parsed) - set opts [dict create] ;#repeated flags will override earlier. That's ok here. - set arglist {} - set got_arglist 0 - set tailtype "" ;#withid|withdef - set id "" - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {[string match -* $a]} { - dict set opts $a [lindex $args $i+1] - incr i - } else { - set arglist $a - set got_arglist 1 - set tailtype [lindex $args $i+1] - if {$tailtype eq "withid"} { - if {[llength $args] != $i+3} { - error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - } - set id [lindex $args $i+2] - break - } elseif {$tailtype eq "withdef"} { - if {[llength $args] < $i+3} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - set deflist [lrange $args $i+2 end] - break - } else { - error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" - } - } - } - if {!$got_arglist} { - error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." - } - #assert tailtype eq withid|withdef - if {$tailtype eq "withid"} { - #assert $id was provided - return "parse [llength $arglist] args withid $id, options:$opts" - } else { - #assert llength deflist >=1 - return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" - } - #TODO - } - - #todo? - a version of get_dict that directly supports punk::lib::tstr templating - #rename get_dict - # - - #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 get_dict {args} { - #see arg_error regarding considerations around unhappy-path performance - - #consider a better API - # - e.g punk::args::parse ?-flag val?... $arglist withid $id - # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? - #can the above be made completely unambiguous for arbitrary arglist?? - #e.g what if arglist = withdef and the first $def is also withdef ? - - - #*** !doctools - #[call [fun get_dict] [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 values - #[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 defining a flag 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 - #[para]Each optionspec line defining a positional argument is of the form: - #[para]argumentname -key val -ky2 val2... - #[para]where the valid keys for each option specification are: -default -type -range -choices - #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value - #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. - #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. - #[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, - #but it could be a manually constructed list of values made for example from positional args defined in the proc. - #[list_end] - #[para] - - #consider line-processing example below for which we need info complete to determine record boundaries - #punk::args::get_dict { - # @opts - # -opt1 -default {} - # -opt2 -default { - # etc - # } - # @values -multiple 1 - #} $args - - set rawargs [lindex $args end] ;# args values to be parsed - #we take a definition list rather than argspecs - because the definition could be dynamic - set definition_args [lrange $args 0 end-1] - - #if definition has been seen before, - #define will either return a permanently cached argspecs (-dynamic 0) - or - # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. - set argspecs [uplevel 1 [list ::punk::args::resolve {*}$definition_args]] - - # ----------------------------------------------- - # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) - tcl::dict::with argspecs {} ;#turn keys into vars - # TODO - capitalise 'define' vars to make it a bit easier - # ----------------------------------------------- - - #puts "-arg_info->$arg_info" - set flagsreceived [list] ;#for checking if required flags satisfied - set solosreceived [list] - #secondary purpose: - #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 ? - - # -- --- --- --- - # Handle leading positionals - # todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ? - set opts $opt_defaults - set pre_values {} - - set argnames [tcl::dict::keys $ARG_INFO] - set optnames [lsearch -all -inline $argnames -*] - set ridx 0 - set rawargs_copy $rawargs - set leader_posn_name "" - set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) - set is_multiple 0 ;#last leader may be multi - if {$LEADER_MAX != 0} { - foreach r $rawargs_copy { - if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { - break - } - if {$ridx == [llength $LEADER_NAMES]-1} { - #at last named leader - set leader_posn_name [lindex $LEADER_NAMES $ridx] - if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { - set is_multiple 1 - } - } elseif {$ridx > [llength $LEADER_NAMES]-1} { - #beyond names - retain name if -multiple was true - if {!$is_multiple} { - set leader_posn_name "" - } - } else { - set leader_posn_name [lindex $LEADER_NAMES $ridx] ;#may return empty string - } - if {$r eq "--"} { - #review end of opts marker: '--' can't be a leader (but can be a value) - break - } - - #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option - if {[tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { - set matchopt [::tcl::prefix::match -error {} $optnames $r] - if {$matchopt ne ""} { - #flaglike matches a known flag - don't treat as leader - break - } - #if {![string match -* [lindex $argnames $ridx]]} {} - if {$leader_posn_name ne ""} { - #there is a named leading positional for this position - #The flaglooking value doesn't match an option - so treat as a leader - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - incr ridx - continue - } else { - break - } - } - - #for each branch - break or lappend - if {$leader_posn_name ne ""} { - if {$leader_posn_name ni $LEADER_REQUIRED} { - #optional leader - - #most adhoc arg processing will allocate based on number of args rather than matching choice values first - #(because a choice value could be a legitimate data value) - - #review - option to process in this manner? - #first check if the optional leader value is a match for a choice ? - #if {[dict exists $arg_info $leader_posn_name -choices]} { - # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] [lindex $rawargs 0]] - # if {$vmatch ne ""} { - # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values - # lappend pre_values [lpop rawargs 0] - # incr ridx - # continue - # } - #} - - #check if enough rawargs to fill any required values - if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { - break - } else { - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #required - if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { - #already accepted at least one value - requirement satisfied - now equivalent to optional - if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { - break - } - } - #if we didn't break - requirement is not yet satisfied, or is satisfied but stil enough rawargs for required values - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #unnamed leader - if {$LEADER_MIN ne "" } { - if {$ridx > $LEADER_MIN} { - break - } else { - #haven't reached LEADER_MIN - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - break - } - } - - incr ridx - } ;# end foreach r $rawargs_copy - } - - set argstate $ARG_INFO ;#argstate may have entries added - set arg_checks $ARG_CHECKS - - if {$LEADER_MIN eq ""} { - set leadermin 0 - } else { - set leadermin $LEADER_MIN - } - if {$LEADER_MAX eq ""} { - set leadermax -1 - } else { - set leadermax $LEADER_MAX - } - - #assert leadermax leadermin are numeric - #assert - rawargs has been reduced by leading positionals - - set leaders [list] - set arglist {} - set post_values {} - #val_min, val_max - #puts stderr "rawargs: $rawargs" - #puts stderr "argstate: $argstate" - if {[lsearch $rawargs -*] >= 0} { - #at least contains flaglike things.. - set maxidx [expr {[llength $rawargs] -1}] - if {$val_max == -1} { - set vals_total_possible [llength $rawargs] - set vals_remaining_possible $vals_total_possible - } else { - set vals_total_possible $val_max - set vals_remaining_possible $vals_total_possible - } - for {set i 0} {$i <= $maxidx} {incr i} { - set a [lindex $rawargs $i] - set remaining_args_including_this [expr {[llength $rawargs] - $i}] - #lowest val_min is 0 - if {$remaining_args_including_this <= $val_min} { - # if current arg is -- it will pass through as a value here - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - - #exlude argument with whitespace from being a possible option e.g dict - if {[tcl::string::match -* $a] && !([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { - if {$a eq "--"} { - #remaining num args <= val_min already covered above - if {$val_max != -1} { - #finite max number of vals - if {$remaining_args_including_this == $val_max} { - #assume it's a value. - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - } else { - #assume it's an end-of-options marker - lappend flagsreceived -- - set arglist [lrange $rawargs 0 $i] - set post_values [lrange $rawargs $i+1 end] - } - } else { - #unlimited number of post_values accepted - #treat this as eopts - we don't care if remainder look like options or not - lappend flagsreceived -- - set arglist [lrange $rawargs 0 $i] - set post_values [lrange $rawargs $i+1 end] - } - break - } else { - set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] - if {$fullopt ne ""} { - if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { - #non-solo - #check if it was actually a value that looked like a flag - if {$i == $maxidx} { - #if no optvalue following - assume it's a value - #(caller should probably have used -- before it) - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - - set flagval [lindex $rawargs $i+1] - if {[tcl::dict::get $argstate $fullopt -multiple]} { - #don't lappend to default - we need to replace if there is a default - if {$fullopt ni $flagsreceived} { - tcl::dict::set opts $fullopt [list $flagval] - } else { - tcl::dict::lappend opts $fullopt $flagval - } - } else { - tcl::dict::set opts $fullopt $flagval - } - #incr i to skip flagval - incr vals_remaining_possible -2 - if {[incr i] > $maxidx} { - arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $fullopt - } - } else { - #solo - if {[tcl::dict::get $argstate $fullopt -multiple]} { - if {$fullopt ni $flagsreceived} { - #override any default - don't lappend to it - tcl::dict::set opts $fullopt 1 - } else { - tcl::dict::lappend opts $fullopt 1 - } - } else { - tcl::dict::set opts $fullopt 1 - } - incr vals_remaining_possible -1 - lapend solosreceived $fullopt - } - lappend flagsreceived $fullopt ;#dups ok - } else { - #unmatched option flag - #comparison to val_min already done above - if {$val_max ne -1 && $remaining_args_including_this <= $val_max} { - #todo - look at optspec_default and see if solo/vs opt-val pair - #we may need to lookahead by 2 regarding val_max val_min - - #even with optany - assume an unknown within the space of possible values is a value - #unmatched option in right position to be considered a value - treat like eopts - #review - document that an unspecified arg within range of possible values will act like eopts -- - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - if {$opt_any} { - set newval [lindex $rawargs $i+1] - #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option - tcl::dict::set argstate $a $optspec_defaults ;#use default settings for unspecified opt - tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS - if {[tcl::dict::get $argstate $a -type] ne "none"} { - if {[tcl::dict::get $argstate $a -multiple]} { - tcl::dict::lappend opts $a $newval - } else { - tcl::dict::set opts $a $newval - } - if {[incr i] > $maxidx} { - arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a - } - incr vals_remaining_possible -2 - } else { - #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none - if {[tcl::dict::get $argstate $a -multiple]} { - if {![tcl::dict::exists $opts $a]} { - tcl::dict::set opts $a 1 - } else { - tcl::dict::lappend opts $a 1 - } - } else { - tcl::dict::set opts $a 1 - } - incr vals_remaining_possible -1 - lappend solosreceived $a - } - lappend flagsreceived $a ;#adhoc flag as supplied - } else { - if {[llength $OPT_NAMES]} { - set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $OPT_NAMES" - } else { - set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": No options defined while @opts -any 0" - } - arg_error $errmsg $argspecs -badarg $fullopt - } - } - } - } else { - #not flaglike - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - } - #set values [list {*}$pre_values {*}$post_values] - set leaders $pre_values - set values $post_values - } else { - set leaders $pre_values - set values $rawargs - #set values [list {*}$pre_values {*}$rawargs] ;#no -flags detected - set arglist [list] - } - #puts stderr "--> arglist: $arglist" - #puts stderr "--> values: $values" - - - set positionalidx 0 ;#index for unnamed positionals (both leaders and values) - set ldridx 0 - set in_multiple "" - set leadernames_received [list] - set leaders_dict $LEADER_DEFAULTS - set num_leaders [llength $leaders] - foreach leadername $LEADER_NAMES ldr $leaders { - if {$ldridx+1 > $num_leaders} { - break - } - if {$leadername ne ""} { - if {[tcl::dict::get $argstate $leadername -multiple]} { - if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { - tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list - } else { - tcl::dict::lappend leaders_dict $leadername $ldr - } - set in_multiple $leadername - } else { - tcl::dict::set leaders_dict $leadername $ldr - } - lappend leadernames_received $leadername - } else { - if {$in_multiple ne ""} { - tcl::dict::lappend leaders_dict $in_multiple $ldr - lappend leadernames_received $in_multiple ;#deliberately allow dups! (as with opts and values) - } else { - tcl::dict::set leaders_dict $positionalidx $ldr - tcl::dict::set argstate $positionalidx $leaderspec_defaults - tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS - lappend leadernames_received $positionalidx - } - } - incr ldridx - incr positionalidx - } - - set validx 0 - set in_multiple "" - set valnames_received [list] - set values_dict $val_defaults - set num_values [llength $values] - foreach valname $VAL_NAMES val $values { - if {$validx+1 > $num_values} { - break - } - if {$valname ne ""} { - if {[tcl::dict::get $argstate $valname -multiple]} { - if {[tcl::dict::exists $val_defaults $valname]} { - #current stored val equals defined default - don't include default in the list we build up - tcl::dict::set values_dict $valname [list $val] ;#important to treat first element as a list - } else { - tcl::dict::lappend values_dict $valname $val - } - set in_multiple $valname - } else { - tcl::dict::set values_dict $valname $val - } - lappend valnames_received $valname - } else { - if {$in_multiple ne ""} { - tcl::dict::lappend values_dict $in_multiple $val - #name already seen - but must add to valnames_received anyway (as with opts and leaders) - lappend valnames_received $in_multiple - } else { - tcl::dict::set values_dict $positionalidx $val - tcl::dict::set argstate $positionalidx $valspec_defaults - tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS - lappend valnames_received $positionalidx - } - } - incr validx - incr positionalidx - } - - if {$leadermax == -1} { - #only check min - if {$num_leaders < $leadermin} { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leadermin" $argspecs - } - } else { - if {$num_leaders < $leadermin || $num_leaders > $leadermax} { - if {$leadermin == $leadermax} { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leadermin" $argspecs - } else { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" $argspecs - } - } - } - - if {$val_max == -1} { - #only check min - if {$num_values < $val_min} { - arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected at least $val_min" $argspecs - } - } else { - if {$num_values < $val_min || $num_values > $val_max} { - if {$val_min == $val_max} { - arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected exactly $val_min" $argspecs - } else { - arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected between $val_min and $val_max inclusive" $argspecs - } - } - } - - #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options - - - #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 SHOULD? 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 - - #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? - #example timing difference: - #struct::set difference {x} {a b} - #normal interp 0.18 u2 vs safe interp 9.4us - #if {[llength [set missing [struct::set difference $opt_required $flagsreceived]]]} { - # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" - #} - #if {[llength [set missing [struct::set difference $val_required $valnames_received]]]} { - # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" - #} - #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us - if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { - arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - if {[llength [set missing [punklib_ldiff $opt_required $flagsreceived]]]} { - arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs - } - if {[llength [set missing [punklib_ldiff $val_required $valnames_received]]]} { - arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - - - #todo - truncate/summarize values in error messages - - #todo - allow defaults outside of choices/ranges - - #check types,ranges,choices - set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] - #set combined_defaults [tcl::dict::merge $val_defaults $opt_defaults] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash - #puts "---opts_and_values:$opts_and_values" - #puts "---argstate:$argstate" - tcl::dict::for {argname v} $opts_and_values { - set thisarg [tcl::dict::get $argstate $argname] - #set thisarg_keys [tcl::dict::keys $thisarg] - set thisarg_checks [tcl::dict::get $arg_checks $argname] - set is_multiple [tcl::dict::get $thisarg -multiple] - set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] - set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] - set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] - set has_default [tcl::dict::exists $thisarg -default] - if {$has_default} { - set defaultval [tcl::dict::get $thisarg -default] - } - set type [tcl::dict::get $thisarg -type] - set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] - set regexprepass [tcl::dict::get $thisarg -regexprepass] - set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 - set validationtransform [tcl::dict::get $thisarg -validationtransform] - - - if {$is_multiple} { - set vlist $v - } else { - set vlist [list $v] - } - set vlist_original $vlist ;#retain for possible final strip_ansi - - #review - validationtransform - if {$is_validate_ansistripped} { - #validate_ansistripped 1 - package require punk::ansi - set vlist_check [list] - foreach e $vlist { - lappend vlist_check [punk::ansi::ansistrip $e] - } - } else { - #validate_ansistripped 0 - set vlist_check $vlist - } - - #reduce our validation requirements by removing values which match defaultval or match -choices - #(could be -multiple with -choicerestriction 0 where some selections match and others don't) - if {$has_choices} { - #-choices must also work with -multiple - #todo -choicelabels - set choiceprefix [tcl::dict::get $thisarg -choiceprefix] - set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] - set choicerestricted [tcl::dict::get $thisarg -choicerestricted] - set choicemultiple [tcl::dict::get $thisarg -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set nocase [tcl::dict::get $thisarg -nocase] - set choices [Dict_getdef $thisarg -choices {}] - set choicegroups [Dict_getdef $thisarg -choicegroups {}] - set allchoices $choices - if {[dict size $choicegroups]} { - dict for {groupname groupmembers} $choicegroups { - lappend allchoices {*}$groupmembers - } - } - #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups - #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes - - - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - set dname leaders_dict - } - option { - set dname opts - } - value { - set dname values_dict - } - } - set idx 0 ;# - #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes - #assert llength $vlist == llength [dict get $dname $argname] - # (unless there was a default and the option wasn't specified) - set vlist_validate [list] - set vlist_check_validate [list] - foreach e $vlist e_check $vlist_check { - set allchoices_in_list 0 - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - #vlist and vlist_check can be list of lists if -multiple and -choicemultiple - #each e represents 0 or more choice selections - set c_list $e - set c_check_list $e_check - #todo? check if entire list matches default? - } else { - #only one choice at a time - ensure single entry in c_list c_check_list - set c_list [list $e] - set c_check_list [list $e_check] - } - - - #----------------------------------- - #fast fail on the wrong number of choices - if {[llength $c_list] < $choicemultiple_min} { - set msg "Option $argname for [Get_caller] requires at least $choicemultiple_min choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { - set msg "Option $argname for [Get_caller] requires at most $choicemultiple_max choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - #----------------------------------- - - set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list - foreach c $c_list c_check $c_check_list { - if {$nocase} { - set casemsg " (case insensitive)" - set choices_test [tcl::string::tolower $allchoices] - #Don't lcase the denylist - even in nocase mode! - #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] - set v_test [tcl::string::tolower $c_check] - } else { - set casemsg " (case sensitive)" - set v_test $c_check - set choices_test $allchoices - } - set choice_in_list 0 - set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? - if {!$matches_default} { - if {$choiceprefix} { - #can we handle empty string as a choice? It should just work - REVIEW/test - set choice_exact_match 0 - if {$c_check in $allchoices} { - #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing - set chosen $c_check - set choice_in_list 1 - set choice_exact_match 1 - } elseif {$v_test in $choices_test} { - #assert - if we're here, nocase must be true - #we know choice is present as full-length match except for case - #now we want to select the case from the choice list - not the supplied value - #we don't set choice_exact_match - because we will need to override the optimistic existing val below - #review - foreach avail [lsort -unique $allchoices] { - if {[string match -nocase $c $avail]} { - set chosen $avail - } - } - #assert chosen will always get set - set choice_in_list 1 - } else { - #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. - #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. - #in this block we can treat empty result from prefix match as a non-match - if {$nocase} { - #nocase implies that our entered value doesn't have to match case of choices - - #but we would still like to select the best match if there are case-dups. - #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete - # selecting Del will find Delete, del will match delete (and raise error) - # but DEL will also match delete rather than Delete - so again an error is raised. - #This is counterintuitive with -nocase - #This is probably such an edge case that best served with documentation as a feature-not-bug - #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? - #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. - - set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] - if {$bestmatch eq ""} { - set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] - #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing - set chosen [lsearch -inline -nocase $allchoices $chosen] - set choice_in_list [expr {$chosen ne ""}] - } else { - set chosen $bestmatch - set choice_in_list 1 - } - } else { - set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] - if {$chosen eq ""} { - set choice_in_list 0 - } else { - set choice_in_list 1 - } - } - #override choice_in_list if in deny list - #don't allow prefixing for elements from -choiceprefixdenylist - #we still use all elements to calculate the prefixes though - #review - case difference edge cases in choiceprefixdenylist !todo - if {$chosen in $choiceprefixdenylist} { - set choice_in_list 0 - set chosen "" - } - } - - #override the optimistic existing val - if {$choice_in_list && !$choice_exact_match} { - if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { - if {$is_multiple} { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $idx $chosen - tcl::dict::set $dname $argname $existing - } else { - tcl::dict::set $dname $argname $chosen - } - } else { - if {$is_multiple} { - set existing_all [tcl::dict::get [set $dname] $argname] - lset existing_all $idx $choice_idx $chosen - tcl::dict::set $dname $argname $existing_all - } else { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $choice_idx $chosen - tcl::dict::set $dname $argname $existing - } - } - } - } else { - #value as stored in $dname is ok - set choice_in_list [expr {$v_test in $choices_test}] - } - } - - if {!$choice_in_list && !$matches_default} { - if {!$choicerestricted} { - #if {$is_multiple} { - # set existing [tcl::dict::get [set $dname] $argname] - # lset existing $idx $v_test - # tcl::dict::set $dname $argname $existing - #} else { - # tcl::dict::set $dname $argname $v_test - #} - lappend vlist_validate $c - lappend vlist_check_validate $c_check - } else { - #unhappy path - if {$choiceprefix} { - set prefixmsg " (or a unique prefix of a value)" - } else { - set prefixmsg "" - } - arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname - } - } - incr choice_idx - } - - incr idx - } - #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation - #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - - if {[llength $vlist] && $has_default} { - set vlist_validate [list] - set vlist_check_validate [list] - foreach c $vlist c_check $vlist_check { - #for -choicemultiple with default that could be a list use 'ni' ?? review - if {$c_check ne $defaultval} { - lappend vlist_validate $c - lappend vlist_check_validate $c - } - } - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - - #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups - #assert: our vlist & vlist_check lists have been reduced to remove those - if {[llength $vlist] && !$is_allow_ansi} { - #allow_ansi 0 - package require punk::ansi - #do not run ta::detect on a list - foreach e $vlist { - if {[punk::ansi::ta::detect $e]} { - error "Option $argname for [Get_caller] contains ansi - but -allow_ansi is false. Received: '$e'" - } - } - } - #puts "argname:$argname v:$v is_default:$is_default" - #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. - #arguments that are at their default are not subject to type and other checks - - #don't validate defaults or choices that matched - #puts "---> opts_and_values: $opts_and_values" - #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" - #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} - - #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups - #assert [llength $vlist] == [llength $vlist_check] - if {[llength $vlist]} { - 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 -badarg $argname - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[llength $e_check] < $checkval} { - arg_error "Option $argname for [Get_caller] requires list with -minsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[llength $e_check] > $checkval} { - arg_error "Option $argname for [Get_caller] requires list with -maxsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - } - } - } - } - } - } - string - ansistring - globstring { - #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string - #we possibly don't want to always have to regex on things that don't pass the other more basic checks - # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) - # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) - # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead - # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function - # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) - # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail - - #todo? - way to validate both unstripped and stripped? - set pass_quick_list_e [list] - set pass_quick_list_e_check [list] - set remaining_e $vlist - set remaining_e_check $vlist_check - #review - order of -regexprepass and -regexprefail in original rawargs significant? - #for now -regexprepass always takes precedence - if {$regexprepass ne ""} { - foreach e $vlist e_check $vlist_check { - if {[regexp $regexprepass $e]} { - lappend pass_quick_list_e $e - lappend pass_quick_list_e_check $e_check - } - } - set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] - set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] - } - if {$regexprefail ne ""} { - foreach e $remaining_e e_check $remaining_e_check { - #puts "----> checking $e vs regex $regexprefail" - if {[regexp $regexprefail $e]} { - if {[tcl::dict::exists $thisarg -regexprefailmsg]} { - set msg [tcl::dict::get $thisarg -regexprefailmsg] - } else { - set msg "Option $argname for [Get_caller] didn't pass regexprefail regex: '$regexprefail' got '$e'" - } - arg_error $msg $argspecs -badarg $argname - } - } - } - switch -- $type { - ansistring { - #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi - #.. so we need to look at the original values in $vlist not $vlist_check - - #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? - #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? - package require punk::ansi - foreach e $remaining_e { - if {![punk::ansi::ta::detect $e]} { - arg_error "Option $argname for [Get_caller] requires ansistring - but no ansi detected" $argspecs -badarg $argname - } - } - } - globstring { - foreach e $remaining_e { - if {![regexp {[*?\[\]]} $e]} { - arg_error "Option $argname for [Get_caller] requires globstring - but no glob characters detected" $argspecs -badarg $argname - } - } - } - } - - if {[tcl::dict::size $thisarg_checks]} { - foreach e_check $remaining_e_check { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[tcl::string::length $e_check] < $checkval} { - arg_error "Option $argname for [Get_caller] requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::string::length $e_check] > $checkval} { - arg_error "Option $argname for [Get_caller] requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - } - } - } - } - } - } - int { - #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive - if {[tcl::dict::exists $thisarg -range]} { - lassign [tcl::dict::get $thisarg -range] low high - if {"$low$high" ne ""} { - if {$low eq ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname - } - #lowside unspecified - check only high - if {$e_check > $high} { - arg_error "Option $argname for [Get_caller] must be integer less than or equal to $high. Received: '$e'" $argspecs -badarg $argname - } - } - } elseif {$high eq ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname - } - #highside unspecified - check only low - if {$e_check < $low} { - arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs -badarg $argname - } - } - } else { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname - } - #high and low specified - if {$e_check < $low || $e_check > $high} { - arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs -badarg $argname - } - } - } - } - } else { - foreach e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e_check'" $argspecs -badarg $argname - } - } - } - } - double { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is double -strict $e_check]} { - error "Option $argname for [Get_caller] requires type 'double'. Received: '$e'" - } - if {[tcl::dict::size $thisarg_checks]} { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -range { - #todo - small-value double comparisons with error-margin? review - #todo - empty string for low or high - lassign $checkval low high - if {$e_check < $low || $e_check > $high} { - arg_error "Option $argname for [Get_caller] must be between $low and $high. Received: '$e'" $argspecs -badarg $argname - } - } - } - } - } - } - } - bool { - foreach e_check $vlist_check { - if {![tcl::string::is boolean -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'boolean'. Received: '$e_check'" $argspecs -badarg $argname - } - } - } - dict { - foreach e_check $vlist_check { - 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 -badarg $argname - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -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 -minsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::dict::size $e_check] > $checkval} { - arg_error "Option $argname for [Get_caller] requires dict with -maxsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - } - } - } - } - } - } - alnum - - alpha - - ascii - - control - - digit - - graph - - lower - - print - - punct - - space - - upper - - wordchar - - xdigit { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is $type $e_check]} { - set msg "Option $argname for [Get_caller] requires type '$type'. Received: '$e'" - #try trap? - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type]]] $result - #throw ? - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname]] $msg - arg_error $msg $argspecs -badarg $argname - } - } - } - file - - directory - - existingfile - - existingdirectory { - foreach e $vlist e_check $vlist_check { - #//review - we may need '?' char on windows - if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { - #what about special file names e.g on windows NUL ? - arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" $argspecs -badarg $argname - } - } - if {$type eq "existingfile"} { - foreach e $vlist e_check $vlist_check { - if {![file exists $e_check]} { - arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing file" $argspecs -badarg $argname - } - } - } elseif {$type eq "existingdirectory"} { - foreach e $vlist e_check $vlist_check { - if {![file isdirectory $e_check]} { - arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing directory" $argspecs -badarg $argname - } - } - } - } - char { - foreach e $vlist e_check $vlist_check { - if {[tcl::string::length $e_check] != 1} { - arg_error "Option $argname for [Get_caller] requires type 'character'. Received: '$e' which is not a single character" $argspecs -badarg $argname - } - } - } - } - - } - - if {$is_strip_ansi} { - set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach - if {[tcl::dict::get $thisarg -multiple]} { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict $argname $stripped_list - } - option { - tcl::dict::set opts $argname $stripped_list - } - value { - tcl::dict::set values_dict $argname $stripped_list - } - } - } else { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict [lindex $stripped_list 0] - } - option { - tcl::dict::set opts $argname [lindex $stripped_list 0] - } - value { - tcl::dict::set values_dict [lindex $stripped_list 0] - } - } - } - } - } - - #maintain order of opts $opts values $values as caller may use lassign. - set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] - if {[llength $receivednames]} { - #flat zip of names with overall posn, including opts - #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] - set i -1 - set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] - } else { - set received_posns [list] - } - #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) - #(e.g using 'dict exists $received -flag') - # - but it can have duplicate keys when args/opts have -multiple 1 - #It is actually a list of paired elements - return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived] - } - - #proc sample1 {p1 args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [opt {?option value...?}]] - # #[para]Description of sample1 - # return "ok" - #} - - - lappend PUNKARGS [list { - @id -id ::punk::args::TEST - @opts -optional 0 - -o1 -default 111 -help "opt 1 mandatory" - @opts -optional 1 - -o2 -default 222 -help "opt 2 optional" - @values -min 0 -max 1 - v -help\ - "v1 optional" - }] - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::lib { - variable PUNKARGS - tcl::namespace::export * - tcl::namespace::path [list [tcl::namespace::parent]] - #*** !doctools - #[subsection {Namespace punk::args::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 flatzip {l1 l2} { - concat {*}[lmap a $l1 b $l2 {list $a $b}] - } - - if {[info commands lseq] ne ""} { - #tcl 8.7+ lseq significantly faster, especially for larger ranges - #The internal rep can be an 'arithseries' with no string representation - proc zero_based_posns {count} { - if {$count < 1} {return} - lseq 0 $count-1 - } - } else { - proc zero_based_posns {count} { - if {$count < 1} {return} - lsearch -all [lrepeat $count 0] * - } - } - - - #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 -1] in calling scope ${[lindex [set x] 0]} !} - lappend PUNKARGS [list { - @id -id ::punk::args::lib::tstr - @cmd -name punk::args::lib::tstr -help\ - "A rough equivalent of js template literals - - Substitutions: - \$\{$varName\} - \$\{[myCommand]\} - (when -allowcommands flag is given)" - -allowcommands -default 0 -type none -help\ - "If -allowcommands is present, placeholder can contain commands - e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" - -undent -default 1 -type boolean -help\ - "undent/dedent the template lines. - The longest common prefix of whitespace is removed" - -indent -default "" -type string -help\ - "String with which to indent the template - prior to substitution. - If -undent is enabled, that is performed - first, then the indent is applied." - -paramindents -default line -choices {none line position} -choicelabels { - line\ - " Use leading whitespace in - the line in which the - placeholder occurs." - position\ - " Use the position in - the line in which the - placeholder occurs." - none\ - " No indents applied to - subsequent placeholder value - lines. This will usually - result in text awkwardly - ragged unless the source code - has also been aligned with the - left margin or the value has - been manually padded." - } -help\ - "How indenting is done for subsequent lines in a - multi-line placeholder substitution value. - The 1st line or a single line value is always - placed at the placeholder. - paramindents are performed after the main - template has been indented/undented. - (indenting by position does not calculate - unicode double-wide or grapheme cluster widths) - " - #choicelabels indented by 1 char is clearer for -return string - and reasonable in table - -return -default string -choices {dict list string args}\ - -choicelabels { - dict\ - " Return a dict with keys - 'template', 'params' and - 'errors'" - string\ - " Return a single result - being the string with - placeholders substituted." - list\ - " Return a 2 element list. - The first is itself a list - of plaintext portions of the - template, split at each point - at which placeholders were - present. The second element - of the outer list is a list - of placeholder values if -eval - is 1, or a list of the raw - placeholder strings if -eval - is 0." - args\ - " Return a list where the first - element is a list of template - plaintext sections as per the - 'list' return mechanism, but the - placeholder items are individual - items in the returned list. - This can be useful when passing - the expanded result of a tstr - command to another function - which expects the placeholders - as individual arguments" - } - -eval -default 1 -type boolean -help\ - "Whether to evaluate the \$\{\} placeholders. - When -return is string, -eval should generally be set to 1. - For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. - contained variables in that case should be braced or whitespace separated, or the variable - name is likely to collide with surrounding text. - e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" - @values -min 0 -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 - e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} - - Escape sequences such as \\n and unicode escapes are processed within placeholders. - " - }] - - proc tstr {args} { - #Too hard to fully eat-our-own-dogfood from within punk::args package - # - we use punk::args within the unhappy path only - #set argd [punk::args::get_by_id ::punk::lib::tstr $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 opt_eval [dict get $argd opts -eval] - - set templatestring [lindex $args end] - set arglist [lrange $args 0 end-1] - set opts [dict create\ - -allowcommands 0\ - -undent 1\ - -indent ""\ - -paramindents line\ - -eval 1\ - -return string\ - ] - if {"-allowcommands" in $arglist} { - set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] - dict set opts -allowcommands 1 - } - if {[llength $arglist] % 2 != 0} { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr expected option/value pairs prior to last argument" - } - } - dict for {k v} $arglist { - set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] - switch -- $fullk { - -indent - -undent - -paramindents - -return - -eval { - dict set opts $fullk $v - } - default { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" - } - } - } - } - set opt_allowcommands [dict get $opts -allowcommands] - set opt_paramindents [dict get $opts -paramindents] - set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] - if {$test_paramindents ni {none line position}} { - error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." - } - set opt_paramindents $test_paramindents - set opt_return [dict get $opts -return] - set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] - if {$opt_return eq ""} { - } - set opt_eval [dict get $opts -eval] - - - set nocommands "-nocommands" - if {$opt_allowcommands == 1} { - set nocommands "" - } - - set opt_undent [dict get $opts -undent] - if {$opt_undent} { - set templatestring [punk::args::lib::undent $templatestring] - } - set opt_indent [dict get $opts -indent] - if {$opt_indent ne ""} { - set templatestring [punk::args::lib::indent $templatestring $opt_indent] - } - - #set parts [_tstr_split $templatestring] - if {[string first \$\{ $templatestring] < 0} { - set parts [list $templatestring] - } else { - set parts [_parse_tstr_parts $templatestring] - } - set textchunks [list] - #set expressions [list] - set params [list] - set idx 0 - set errors [dict create] - set lastline "" ;#todo - first line has placeholder? - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach {pt expression} $parts { - lappend textchunks $pt - incr idx ;#pt incr - - #ignore last expression - if {$idx == [llength $parts]} { - break - } - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - #lappend expressions $expression - #---------------------- - #REVIEW - JMN - #TODO - debug punk::args loading of @dynamic defs - #puts "-- $expression" - #---------------------- - #brk1 - literal newline not {\n} - set leader "" - if {[set brk1 [string first \n $expression]] >= 0} { - #undent left of paramstart only for lines of expression that arent on opening ${..} line - set tail [string range $expression $brk1+1 end] - set leader [string repeat " " [string length $lastline]] - set undentedtail [punk::args::lib::undentleader $tail $leader] - #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] - set expression "[string range $expression 0 $brk1]$undentedtail" - } - if {$opt_eval} { - if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { - lappend params [string cat \$\{ $expression \}] - dict set errors [expr {[llength $params]-1}] $result - } else { - set result [string map [list \n "\n$leader"] $result] - lappend params $result - } - #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] - } else { - lappend params [subst -nocommands -novariables $expression] - } - append lastline [lindex $params end] ;#for current expression's position calc - - incr idx ;#expression incr - } - - if {$opt_return eq "dict"} { - return [dict create template $textchunks params $params errors $errors] - } - if {[dict size $errors]} { - set einfo "" - dict for {i e} $errors { - append einfo "parameter $i error: $e" \n - } - #REVIEW!!! - #TODO - fix - #puts stderr "tstr errors:\n$einfo\n" - } - - switch -- $opt_return { - list { - return [list $textchunks $params] - } - args { - #see example in tstr_test_one - return [list $textchunks {*}$params] - } - string { - #todo - flag to disable indent-matching behaviour for multiline param? - set out "" - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach pt $textchunks param $params { - if {$opt_paramindents eq "none"} { - append out $pt $param - } else { - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - if {$opt_paramindents eq "line"} { - regexp {(\s*).*} $lastline _all lastindent - } else { - #position - #TODO - detect if there are grapheme clusters - #This regsub doesn't properly space unicode double-wide chars or clusters - set lastindent "[regsub -all {\S} $lastline " "] " - } - if {$lastindent ne ""} { - set paramlines [split $param \n] - if {[llength $paramlines] == 1} { - append out $pt $param - } else { - append out $pt [lindex $paramlines 0] - foreach nextline [lrange $paramlines 1 end] { - append out \n $lastindent $nextline - } - } - } else { - append out $pt $param - } - append lastline $param - } - } - return $out - } - } - } - #test single placeholder tstr args where single placeholder must be an int - proc tstr_test_one {args} { - set argd [punk::args::get_dict { - @cmd -name ::punk::args::lib::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 -return args {Select * from table where id = \$\{$id\} and etc... ;}] - } - - @values -min 2 -max 2 - template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - - but the tstr call in the example 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]] ""] - set result [string cat [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 dollar sign - 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]] - } - - #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. - proc indent {text {prefix " "}} { - set result [list] - foreach line [split $text \n] { - if {[string trim $line] eq ""} { - lappend result "" - } else { - lappend result $prefix[string trimright $line] - } - } - return [join $result \n] - } - #dedent? - proc undent {text} { - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - regexp {^([\t ]*)} $lcp _m lcp - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - - #hacky - proc undentleader {text leader} { - #leader usually whitespace - but doesn't have to be - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - lappend nonblank "${leader}!!" - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - #regexp {^([\t ]*)} $lcp _m lcp - #lcp can be shorter than leader - set lcp [string range $lcp 0 [string length $leader]-1] - - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - #A version of textutil::string::longestCommonPrefixList - proc longestCommonPrefix {items} { - if {[llength $items] <= 1} { - return [lindex $items 0] - } - set items [lsort $items[unset items]] - set min [lindex $items 0] - set max [lindex $items end] - #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) - #(sort order nothing to do with length - e.g min may be longer than max) - if {[string length $min] > [string length $max]} { - set temp $min - set min $max - set max $temp - } - set n [string length $min] - set prefix "" - set i -1 - while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { - append prefix $c - } - return $prefix - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] -} - -tcl::namespace::eval punk::args::argdocbase { - namespace export * - #use a? to test and create literal ansi here rather than relying on punk::ansi package presence - #e.g - #% a? bold - #- bold │SGR 1│sample│␛[1msample - #- ──────┼─────┼──────┼────────── - #- RESULT│ │sample│␛[1msample - proc B {} {return \x1b\[1m} ;#a+ bold - proc N {} {return \x1b\[22m} ;#a+ normal - proc I {} {return \x1b\[3m} ;#a+ italic - proc NI {} {return \x1b\[23m} ;#a+ noitalic - -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::package { - variable PUNKARGS - lappend PUNKARGS [list { - @dynamic - @id -id "::punk::args::package::standard_about" - @cmd -name "%pkg%::about" -help\ - "About %pkg% - ... - " - -package_about_namespace -type string -optional 0 -help\ - "Namespace containing the package about procedures - Must contain " - -return\ - -type string\ - -default table\ - -choices {string table tableobject}\ - -choicelabels { - string\ - "A basic text layout" - table\ - "layout in table borders - (requires package: textblock)" - tableobject\ - "textblock::class::table object instance" - }\ - -help\ - "Choose the return type of the 'about' information" - topic -optional 1\ - -nocase 1\ - -default {*}\ - -choices {Description License Version Contact *}\ - -choicerestricted 0\ - -choicelabels { - - }\ - -multiple 1\ - -help\ - "Topic to display. Omit or specify as * to see all. - If * is included with explicit topics, * represents - the remaining unmentioned topics." - }] - proc standard_about {args} { - set argd [punk::args::parse $args withid ::punk::args::package::standard_about] - lassign [dict values $argd] leaders OPTS values received - - set pkgns [dict get $OPTS -package_about_namespace] - if {[info commands ${pkgns}::package_name] eq ""} { - error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" - } - set pkgname [${pkgns}::package_name] - - set opt_return [dict get $OPTS -return] - set all_topics [${pkgns}::about_topics] - if {![dict exists $received topic]} { - set topics $all_topics - } else { - # * represents all remaining topics not explicitly mentioned. - set val_topics [dict get $values topic] ;#if -multiple is true, this is a list - set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] - set topics [list] - foreach t $val_topics { - if {$t eq "*"} { - foreach a $all_topics { - if {$a ni $explicit_topics} { - lappend topics $a - } - } - } else { - lappend topics $t - } - } - } - if {$opt_return ne "string"} { - package require textblock ;#table support - set is_table 1 - set title [string cat {[} $pkgname {]} ] - set t [textblock::class::table new -title $title] - $t configure -frametype double -minwidth [expr {[string length $title]+2}] - - } else { - set topiclens [lmap t $topics {string length $t}] - set widest_topic [tcl::mathfunc::max {*}$topiclens] - set is_table 0 - set about "$pkgname\n" - append about [string repeat - $widest_topic] \n - } - foreach topic $topics { - if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { - set topic_contents [::${pkgns}::get_topic_$topic] - } else { - set topic_contents "" - } - if {!$is_table} { - set content_lines [split $topic_contents \n] - append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n - foreach ln [lrange $content_lines 1 end] { - append about [format %-${widest_topic}s ""] " " $ln \n - } - } else { - $t add_row [list $topic $topic_contents] - } - } - - if {!$is_table} { - return $about - } else { - if {$opt_return eq "tableobject"} { - return $t - } - set result [$t print] - $t destroy - return $result - } - } - -} - -#usually we would directly call arg definitions near the defining proc, -# so that the proc could directly use the definition in its parsing. -# -#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. -#arguably it may be more processor-cache-efficient to do together like this anyway. - -#can't do this here? - as there is circular dependency with punk::lib -#tcl::namespace::eval punk::args { -# foreach deflist $PUNKARGS { -# punk::args::define {*}$deflist -# } -# set PUNKARGS "" -#} - -lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -tcl::namespace::eval punk::args::system { - #*** !doctools - #[subsection {Namespace punk::args::system}] - #[para] Internal functions that are not part of the API - - #dict get value with default wrapper for tcl 8.6 - if {[info commands ::tcl::dict::getdef] eq ""} { - proc Dict_getdef {dictValue args} { - set keys [lrange $args 0 end-1] - if {[tcl::dict::exists $dictValue {*}$keys]} { - return [tcl::dict::get $dictValue {*}$keys] - } else { - return [lindex $args end] - } - } - } else { - #we pay a minor perf penalty for the wrap - interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef - } - - #name to reflect maintenance - home is punk::lib::ldiff - proc punklib_ldiff {fromlist removeitems} { - if {[llength $removeitems] == 0} {return $fromlist} - set result {} - foreach item $fromlist { - if {$item ni $removeitems} { - lappend result $item - } - } - return $result - } - -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::args [tcl::namespace::eval punk::args { - tcl::namespace::path {::punk::args::lib ::punk::args::system} - variable pkg punk::args - variable version - set version 0.1.1 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.4.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.4.tm deleted file mode 100644 index e1256fe4..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.4.tm +++ /dev/null @@ -1,5502 +0,0 @@ -# -*- 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: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.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 punk::args 0.1.4 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.1.4] -#[copyright "2024"] -#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] -#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] -#[require punk::args] -#[keywords module proc args arguments parse] -#[description] -#[para]Utilities for parsing proc args - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). -#[para] overview of punk::args -#[subsection Concepts] -#[para]There are 2 main conventions for parsing a proc args list -#[list_begin enumerated] -#[enum] -#[para]leading option-value pairs and flags followed by a list of values (Tcl style) -#[enum] -#[para]leading list of values followed by option-value pairs and flags (Tk style) -#[list_end] -#[para]There are exceptions in both Tcl and Tk commands regarding this ordering -#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style -#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] -#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. -#[para] -#[para]The basic principle is that a call to punk::args::get_dict is made near the beginning of the proc with a cacheable first argument defining the parameters e.g -#[example { -# proc dofilestuff {args} { -# lassign [dict values [punk::args::get_dict { -# @cmd -help "do some stuff with files e.g dofilestuff " -# @opts -type string -# #comment lines ok -# -directory -default "" -# -translation -default binary -# #setting -type none indicates a flag that doesn't take a value (solo flag) -# -nocomplain -type none -# @values -min 1 -max -1 -# } $args]] leaders opts values -# -# puts "translation is [dict get $opts -translation]" -# foreach f [dict values $values] { -# puts "doing stuff with file: $f" -# } -# } -#}] -#[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls -#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values -#[para]valid @ lines being with @cmd @leaders @opts @values -#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. -#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. -#[para]e.g the result from the punk::args call above may be something like: -#[para] opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} -#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments -#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments -#[example { -# proc dofilestuff {category args} { -# lassign [dict values [punk::args::get_dict { -# -directory -default "" -# -translation -default binary -# -nocomplain -type none -# @values -min 2 -max 2 -# fileA -type existingfile 1 -# fileB -type existingfile 1 -# } $args]] leaders opts values -# puts "$category fileA: [dict get $values fileA]" -# puts "$category fileB: [dict get $values fileB]" -# } -#}] -#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 -#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored -#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, -#[para] or an additional call could be made to punk::args e.g -#[example { -# punk::args::get_dict { -# category -choices {cat1 cat2 cat3} -# another_leading_arg -type boolean -# } [list $category $another_leading_arg] -#}] - -#*** !doctools -#[subsection Notes] -#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. -#[para] -#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. -#For functions that are part of an API a package may be more suitable. -#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) -#[example { -# proc test_switch {args} { -# set opts [dict create\\ -# -return "object"\\ -# -frametype "heavy"\\ -# -show_edge 1\\ -# -show_seps 0\\ -# -x a\\ -# -y b\\ -# -z c\\ -# -1 1\\ -# -2 2\\ -# -3 3\\ -# ] -# foreach {k v} $args { -# switch -- $k { -# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { -# dict set opts $k $v -# } -# default { -# error "unrecognised option '$k'. Known options [dict keys $opts]" -# } -# } -# } -# return $opts -# } -#}] -#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. -#[para] -# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. -# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. -#[para]use punk::lib::show_jump_tables to verify that a jump table exists. -#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous -#[example { -# proc test_prefix {args} { -# set opts [dict create\ -# -return string\ -# -frametype \uFFEF\ -# -show_edge \uFFEF\ -# -show_seps \uFFEF\ -# -x a\ -# -y b\ -# -z c\ -# -1 1\ -# -2 2\ -# -3 3\ -# ] -# if {[llength $args]} { -# set knownflags [dict keys $opts] -# } -# foreach {k v} $args { -# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v -# } -# return $opts -# } -#}] -#[para]There are many alternative args parsing packages a few of which are listed here. -#[list_begin enumerated] -#[enum]argp (pure tcl) -#[enum]parse_args (c implementation) -#[enum]argparse (pure tcl *) -#[enum]cmdline (pure tcl) -#[enum]opt (pure tcl) distributed with Tcl but considered deprecated -#[enum]The tcllib set of TEPAM modules (pure tcl) -#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. -#[list_end] -#[para] (* c implementation planned/proposed) -#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. -#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences -#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. -#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. -#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. -#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. -#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -#All ensemble commands are slower in a safe interp as they aren't compiled the same way -#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 -#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. -#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) -#ensembles: array binary clock dict info namespace string -#possibly file too, although that is generally hidden/modified in a safe interp -#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc -#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::args -#[list_begin itemized] -package require Tcl 8.6- -#optional? punk::trie -#optional? punk::textblock -#*** !doctools -#[item] [package {Tcl 8.6-}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -tcl::namespace::eval punk::args::register { - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] cooperative namespace punk::args::register - #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded - #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. - #[list_begin definitions] - - #Although the actual punk::args::define calls are not too sluggish, there could be *many*. - #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, - #especially since a fair proportion may be for documentation purposes rather than parsing args. - - # -- --- --- --- --- --- --- --- - #cooperative with packages that define some punk args but do so lazily - #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first - variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective - if {![info exists ::punk::args::register::NAMESPACES]} { - set ::punk::args::register::NAMESPACES [list] - } - # -- --- --- --- --- --- --- --- - - variable loaded_packages [list] ;#fully loaded - variable loaded_info [dict create] ;#time - variable scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages - variable scanned_info [dict create] ;#time and idcount - #some packages, e.g punk::args::tclcore document other namespaces. - #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources - variable namespace_docpackages [dict create] - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::register ---}] -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args { - - - variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. - - tcl::namespace::export {[a-z]*} - variable rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} - variable id_cache_rawdef [tcl::dict::create] - variable id_cache_spec [tcl::dict::create] - - variable argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) - - variable argdata_cache [tcl::dict::create] - - variable id_counter 0 - - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] Core API functions for punk::args - #[list_begin definitions] - - #todo - some sort of punk::args::cherrypick operation to get spec from an existing set - #todo - doctools output from definition - - - - - #todo? -synonym/alias ? (applies to opts only not values) - #e.g -background -aliases {-bg} -default White - #review - how to make work with trie prefix - #e.g - # -corner -aliases {-corners} - # -centre -aliases {-center -middle} - #We mightn't want the prefix to be longer just because of an alias - #we should get -co -ce and -m from the above as abbreviations - - set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] - - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::define - #todo @preamble -help "move large block outside of table?" - @cmd -name punk::args::define -help\ - "Accepts a line-based definition of command arguments. - Returns a dictionary representing the argument specifications. - - The return result can generally be ignored, as the record is stored keyed on the - @id -id value from the supplied definition. - This specifications dictionary is structured for (optional) use within commands to - parse and validate the arguments - and is also used when retrieving definitions - (or parts thereof) for re-use. - - This can be used purely for documentation or called within a function to parse a mix - of leading values, switches/flags and trailing values. - - The overhead is favourably comparable with other argument processors - but none are - as fast as minimal code with a switch statement. For toplevel commands where a few - 10s of microseconds is immaterial, the validation and automated error formatting in - a table can be well worthwhile. For inner procs requiring utmost speed, the call can - be made only on the unhappy path when basic processing determines a mismatch - or it - can be left entirely as documentation for interactive use with: i ... - - The definition should usually contain an initial line of the form: @id -id ::somecmd - - Blank lines are ignored at the top level, ie if they are not part of another structure. - Similarly - lines at the top level begginning with the # character are ignored. - All other toplevel lines must consist of a leading word followed by paired arguments. - The arguments can be spread over multiple lines and contain lines of near-arbitrary - text if they are properly braced or double quoted and Tcl escaping for inner quotes - or unbalanced braces is maintained. - The line continuation character - (\\ at the end of the line) can be used to continue the set of arguments for - a leading word. - Leading words beginning with the @ character are directives controlling argument - parsing and help display. - directives include: - %B%@id%N% ?opt val...? - spec-options: -id - %B%@cmd%N% ?opt val...? - spec-options: -name -help - %B%@leaders%N% ?opt val...? - spec-options: -min -max - (used for leading args that come before switches/opts) - %B%@opts%N% ?opt val...? - spec-options: -any - %B%@values%N% ?opt val...? - spec-options: -min -max - (used for trailing args that come after switches/opts) - %B%@argdisplay%N% ?opt val...? - spec-options: -header (text for header row of table) - -body (text to replace autogenerated arg info) - %B%@doc%N% ?opt val...? - spec-options: -name -url - %B%@seealso%N% ?opt val...? - spec-options: -name -url (for footer - unimplemented) - - Some other spec-options normally present on custom arguments are available - to use with the @leaders @opts @values directives to set defaults - for subsequent lines that represent your custom arguments. - These directives should occur in exactly this order - but can be - repeated with custom argument lines interspersed. - - An @id line can only appear once and should be the first item. - For the commandline usage to be displayed either on parsing error - or using the i .. function - an @id with -id is needed. - - All directives can be omitted, in which case every line represents - a custom leader, value or option. - All will be leaders by default if no options defined. - If options are defined (by naming with leading dash, or explicitly - specifying @opts) then the definitions prior to the options will be - categorised as leaders, and those following the options will be - categorised as values. - - Custom arguments are defined by using any word at the start of a - line that doesn't begin with @ or - - (except that adding an additionl @ escapes this restriction so - that @@somearg becomes an argument named @somearg) - - custom leading args, switches/options (names starting with -) - and trailing values also take spec-options: - - -type - defaults to string. If no other restrictions - are specified, choosing string does the least validation. - recognised types: - none - (used for switches only. Indicates this is - a 'solo' flag ie accepts no value) - int|integer - list - dict - double - bool|boolean - char - file - directory - string - ansistring - globstring - (any of the types accepted by 'string is') - - These all perform some validation checks - - and more.. (todo - document here) - - -optional - (defaults to true for flags/switches false otherwise) - For non flag/switch arguments - all arguments with - -optional true must sit consecutively within their group. - ie all optional leader arguments must be together, and all - optional value arguments must be together. Furthermore, - specifying both optional leaders and optional values will - often lead to ambiguous parsing results. Currently, all - optional non-flg/switch arguments should be either at the - trailing end of leaders or the trailing end of values. - Further unambiguous arrangements of optional args may be - made in future - but are currently considered 'unsupported' - -default - -multiple (for leaders & values defines whether - subsequent received values are stored against the same - argument name - only applies to final leader OR final value) - (for options/flags this allows the opt-val pair or solo - flag to appear multiple times - not necessarily contiguously) - -choices {} - A list of allowable values for an argument. - The -default value doesn't have to be in the list. - If a -type is specified - it doesn't apply to choice members. - It will only be used for validation if the -choicerestricted - option is set to false. - -choicerestricted - Whether values not specified in -choices or -choicegroups are - allowed. Defaults to true. - -choiceprefix - This specifies whether unique prefixes are able to be used - instead of the complete string. This is calculated using - tcl::prefix::match - and will display in the autogenerated - usage output. Defaults to true. - -choiceprefixdenylist {} - These choices should match exactly a choice entry in one of - the settings -choices or -choicegroups. - These will still be used in prefix calculation - but the full - choice argument must be entered to select the choice. - -choicegroups {} - Generally this would be used instead of -choices to allow - usage display of choices grouped by some name. - See for example the output if 'i zlib' where choices of the - next subcommand are grouped by the names compression,channel, - streaming and checksumming. The -choices list is equivalent - to a -choicegroups dict entry where the key (groupname) is - the empty string. - -choicemultiple (default {1 1}) - is a pair representing min and max number of choices - that can be present in the value. - If is a single integer it is equivalent to a - specified with the same integer for both min and max. - Max of -1 represents no upper limit. - If allows more than one choice the value is a list - consisting of items in the choices made available through - entries in -choices/-choicegroups. - -minsize (type dependant) - -maxsize (type dependant) - -range (type dependant) - - - " - -dynamic -type boolean -default 0 -help\ - "If -dynamic is true, tstr interpolations of the form \$\{\$var\} - are re-evaluated on each call. - If the definition is being used not just as documentation, but is also - used within the function to parse args, e.g using punk::args::get_by_id, - then it should be noted that there is a slight performance penalty for the - dynamic case. - It is often not significant, perhaps depending on what vars/commands are - used but -dynamic true might be less desirable if the command is used in - inner loops in more performance-sensitive code. - " - @values -min 1 -max -1 - text -type string -multiple 1 -help\ - "Block(s) of text representing the argument definition for a command. - At least one must be supplied. If multiple, they are joined together with \\n. - Using multiple text arguments may be useful to mix curly-braced and double-quoted - strings to have finer control over interpolation when defining arguments. - (this can also be handy for sections that pull resolved definition lines - from existing definitions (by id) for re-use of argument specifications and help text) - - e.g the following definition passes 2 blocks as text arguments - definition { - @id -id ::myns::myfunc - @cmd -name myns::myfunc -help\\ - \"Description of command\" - - #The following option defines an option-value pair - -option1 -default blah -type string - #The following option defines a flag style option (solo) - -flag1 -default 0 -type none -help\\ - \"Info about flag1 - subsequent help lines auto-dedented by whitespace to left - of corresponding record start (in this case -flag1) - + first 4 spaces if they are all present. - This line has no extra indent relative to first line 'Info about flag1' - This line indented a further 6 chars\" - - @values -min 1 -max -1 - #Items that don't begin with * or - are value definitions - v1 -type integer -default 0 - thinglist -type string -multiple 1 - } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" - " - }]] - - proc New_command_form {name} { - #probably faster to inline a literal dict create in the proc than to use a namespace variable - set leaderspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - set optspec_defaults [tcl::dict::create\ - -type string\ - -optional 1\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - set valspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - - #form record can have running entries such as 'argspace' that aren't given to arg parser - #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict - return [dict create\ - argspace "leaders"\ - ARG_INFO [tcl::dict::create]\ - ARG_CHECKS [tcl::dict::create]\ - LEADER_DEFAULTS [tcl::dict::create]\ - LEADER_REQUIRED {}\ - LEADER_NAMES {}\ - LEADER_MIN ""\ - LEADER_MAX ""\ - leaderspec_defaults $leaderspec_defaults\ - LEADER_CHECKS_DEFAULTS {}\ - opt_default {}\ - opt_required {}\ - OPT_NAMES {}\ - opt_any {}\ - opt_solos {}\ - optspec_defaults $optspec_defaults\ - OPT_CHECKS_DEFAULTS {}\ - val_defaults {}\ - val_required {}\ - VAL_NAMES {}\ - val_min ""\ - val_max ""\ - valspec_defaults $valspec_defaults\ - VAL_CHECKS_DEFAULTS {}\ - argdisplay_info ""\ - ] - - #set argdata_dict [tcl::dict::create\ - # id $DEF_definition_id\ - # arg_info $arg_info\ - # arg_checks $arg_checks\ - # leader_defaults $leader_defaults\ - # leader_required $leader_required\ - # leader_names $leader_names\ - # leader_min $leader_min\ - # leader_max $leader_max\ - # leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ - # leader_checks_defaults $leader_checks_defaults\ - # opt_defaults $opt_defaults\ - # opt_required $opt_required\ - # opt_names $opt_names\ - # opt_any $opt_any\ - # opt_solos $opt_solos\ - # optspec_defaults [dict get $F $firstformid optspec_defaults]\ - # opt_checks_defaults $opt_checks_defaults\ - # val_defaults $val_defaults\ - # val_required $val_required\ - # val_names $val_names\ - # val_min $val_min\ - # val_max $val_max\ - # valspec_defaults [dict get $F $firstformid valspec_defaults]\ - # val_checks_defaults $val_checks_defaults\ - # cmd_info $cmd_info\ - # doc_info $doc_info\ - # argdisplay_info $argdisplay_info\ - # id_info $id_info\ - # form_defs $F\ - #] - } - - proc errorstyle {args} { - #set or query the running config -errorstyle - #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? - #values: - #debug, enhanced, standard, basic, minimal - error todo - } - proc define {args} { - dict get [resolve {*}$args] id - } - proc resolve {args} { - variable rawdef_cache - variable id_cache_rawdef - if {[dict exists $rawdef_cache $args]} { - set id [dict get $rawdef_cache $args -id] - set is_dynamic [dict get $rawdef_cache $args -dynamic] - } else { - set id [rawdef_id $args] - set is_dynamic [rawdef_is_dynamic $args] - dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] - dict set id_cache_rawdef $id $args - } - - - variable argdata_cache - variable argdefcache_unresolved - - - set cache_key $args - #ideally we would use a fast hash algorithm to produce a short key with low collision probability. - #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) - #review - check if there is a built-into-tcl way to do this quickly - #for now we will just key using the whole string - #performance seems ok - memory usage probably not ideal - #quote from DKF 2021 - #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. - #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. - #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. - #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). - #> If dealing with very large amounts of data, using a database is probably a good plan. - - set textargs $args - if {![llength $args]} { - punk::args::get_by_id ::punk::args::define {} - return - } - if {[lindex $args 0] eq "-dynamic"} { - set is_dynamic [lindex $args 1] - set textargs [lrange $args 2 end] - } - - if {!$is_dynamic} { - if {[tcl::dict::exists $argdata_cache $cache_key]} { - return [tcl::dict::get $argdata_cache $cache_key] - } - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - if {[string first \$\{ $optionspecs] > 0} { - set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } - } else { - #we are always doing our first subst during the define.. shouldn't it be a separate resolve somehow? optionally so at least? - - if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { - set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel 1 [list ::subst $param]] - } - } else { - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) - if {[string first \$\{ $optionspecs] > 0} { - set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel 1 [list ::subst $param]] - } - tcl::dict::set argdefcache_unresolved $cache_key $pt_params - } - } - #argdata_cache should be limited in some fashion or will be a big memory leak??? - if {[tcl::dict::exists $argdata_cache $optionspecs]} { - #resolved cache version exists - return [tcl::dict::get $argdata_cache $optionspecs] - } - } - - - - #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices - #default to 1 for convenience - - #checks with no default - #-minsize -maxsize -range - - - #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi - #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist - set opt_required [list] - set val_required [list] - - set opt_defaults [tcl::dict::create] - - set val_defaults [tcl::dict::create] - set opt_solos [list] - #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end - - set records [list] - set linebuild "" - - set linelist [split $optionspecs \n] - set lastindent "" - foreach ln $linelist { - if {[tcl::string::trim $ln] eq ""} {continue} - regexp {(\s*).*} $ln _all lastindent - break ;#break at first non-empty - } - #puts "indent1:[ansistring VIEW $lastindent]" - set in_record 0 - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - foreach rawline $linelist { - set recordsofar [tcl::string::cat $linebuild $rawline] - #ansi colours can stop info complete from working (contain square brackets) - #review - when exactly are ansi codes allowed/expected in record lines. - # - we might reasonably expect them in default values or choices or help strings - # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. - # - eg set line "set x \"a[a+ red]red[a]\"" - # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket - if {$has_punkansi} { - set test_complete [punk::ansi::ansistrip $recordsofar] - } else { - #review - #we only need to strip enough to stop interference with 'info complete' - set test_complete [string map [list \x1b\[ ""] $recordsofar] - } - if {![tcl::info::complete $test_complete]} { - #append linebuild [string trimleft $rawline] \n - if {$in_record} { - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. - #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. - #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. - #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) - #(note string first "" $str is fast and returns -1) - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline \n - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline \n - } else { - append linebuild $rawline \n - } - } else { - set in_record 1 - regexp {(\s*).*} $rawline _all lastindent - #puts "indent: [ansistring VIEW -lf 1 $lastindent]" - #puts "indent from rawline:$rawline " - append linebuild $rawline \n - } - } else { - set in_record 0 - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline - } else { - append linebuild $rawline - } - lappend records $linebuild - set linebuild "" - } - } - set cmd_info {} - set package_info {} - set id_info {} ;#e.g -children ?? - set doc_info {} - set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table - set seealso_info {} - set keywords_info {} - ###set leader_min 0 - ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit - #set leader_max "" - #(common case of no leaders specified) - set opt_any 0 - set val_min 0 - set val_max -1 ;#-1 for no limit - set DEF_definition_id $id - - #form_defs - set F [dict create _default [New_command_form _default]] - set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under - - #set ARGSPACE [dict create] ;#keyed on form - #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values - - set refs [dict create] - set record_type "" - set record_number -1 ;# - foreach rec $records { - set trimrec [tcl::string::trim $rec] - switch -- [tcl::string::index $trimrec 0] { - "" - # {continue} - } - incr record_number - set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict - if {[llength $record_values] % 2 != 0} { - #todo - avoid raising an error - store invalid defs keyed on id - error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" - } - # ---------------------------------------------------------- - # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. - #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! - #(form_ids_active is otherwise set in the @form handling block) - - #consider the following 2 line entry which is potentially dynamically included via a tstr: - # @form -form {* newform} - # @form -form {newform} -synopsis "cmd help ?stuff?" - #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. - #(because _default is usually 'taken over' by the first encountered form id) - #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record - #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. - - if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { - set patterns [dict get $record_values -form] - set record_form_ids [list] - foreach p $patterns { - if {[regexp {[*?\[\]]} $p]} { - #isglob - only used for matching existing forms - lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] - } else { - #don't test for existence - will define new form if necessary - lappend record_form_ids $p - } - } - #-form values could be globs that didn't match. record_form_ids could be empty.. - if {[llength $record_form_ids]} { - #only rename _default if it's the sole entry - if {[dict size $F] == 1 && [dict exists $F "_default"]} { - if {"_default" ni $record_form_ids} { - #only initial form exists - but we are mentioning new ones - #first rename the _default to first encountered new form id - #(just replace whole dict with new key - same data) - set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] - #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F - #we are only setting active because of the rename - @form is the way to change active forms list - set form_ids_active [lindex $record_form_ids 0] - } - } - foreach fid $record_form_ids { - if {![dict exists $F $fid]} { - if {$firstword eq "@form"} { - #only @form directly supplies keys - dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] - } else { - dict set F $fid [New_command_form $fid] - } - } else { - #update form with current record opts, except -form - if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } - } - } - } - } else { - #missing or empty -form - set record_form_ids $form_ids_active - if {$firstword eq "@form"} { - foreach fid $form_ids_active { - dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] - } - } - } - # ---------------------------------------------------------- - - set firstchar [tcl::string::index $firstword 0] - set secondchar [tcl::string::index $firstword 1] - if {$firstchar eq "@" && $secondchar ne "@"} { - set record_type "directive" - set directive_name $firstword - set at_specs $record_values - - switch -- [tcl::string::range $directive_name 1 end] { - dynamic { - set is_dynamic 1 - } - id { - #disallow duplicate @id line ? - #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) - - #id An id will be allocated if no id line present or the -id value is "auto" - - if {[dict exists $at_specs -id]} { - set thisid [dict get $at_specs -id] - if {$thisid ni [list $id auto]} { - error "punk::args::define @id mismatch existing: $id vs $thisid" - } - } - set id_info $at_specs - } - ref { - #a reference within the definition - #e.g see punk::args::tclcore ::after - #global reference dict - independent of forms - #ignore refs without an -id - #store all keys except -id - #complete overwrite if refid repeated later on - if {[dict exists $at_specs -id]} { - dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] - } - } - default { - #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple - #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) - #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) - #That is possibly too complicated and/or unnecessary? - #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? - - if {[dict exists $at_specs -id]} { - set copyfrom [get_spec [dict get $at_specs -id]] - #we don't copy the @id info from the source - #for now we only copy across if nothing set.. - #todo - bring across defaults for empty keys at targets? - #need to keep it simple enough to reason about behaviour easily.. - if {[dict size $copyfrom]} { - if {![dict size $cmd_info]} { - set cmd_info [dict get $copyfrom cmd_info] - } - if {![dict size $doc_info]} { - set doc_info [dict get $copyfrom doc_info] - } - foreach fid $record_form_ids { - #only use elements with matching form id? - #probably this feature mainly useful for _default anyway so that should be ok - #cooperative doc sets specified in same file could share via known form ids too - #todo argdisplay_info by fid - if {![dict size $argdisplay_info]} { - set argdisplay_info [dict get $copyfrom argdisplay_info] - } - #TODO - #create leaders opts vals depending on position of @default line? - #options on @default line to exclude/include sets??? - } - } - } - } - form { - # arity system ? - #handle multiple parsing styles based on arities and keyword positions (and/or flags?) - #e.g see lseq manual with 3 different parsing styles. - #aim to produce a table/subtable for each - # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ - # -arities { - # 2 - # {3 anykeys {1 .. 1 to}} - # {4 anykeys {3 by}} - # {5 anykeys {1 .. 1 to 3 by}} - # }\ - # -fallback 1 - # ... - # @parser -synopsis "start 'count' count ??'by'? step?"\ - # -arities { - # {3 anykeys {1 count}} - # } - # ... - # @form -synopsis "count ?'by' step?"\ - # -arities { - # 1 - # {3 anykeys {1 by}} - # } - # - # see also after manual - # @form -arities {1} - # @form -arities { - # 1 anykeys {0 info} - # } - #todo - - #can we generate a form synopsis if -synopsis not supplied? - - #form id can be list of ints|names?, or * - if {[dict exists $at_specs -form]} { - set idlist [dict get $at_specs -form] - if {$idlist eq "*"} { - #* only applies to form ids that exist at the time - set idlist [dict keys $F] - } - set form_ids_active $idlist - } - #new form keys already created if they were needed (done for all records that have -form ) - } - package { - set package_info [dict merge $package_info $at_specs] - } - cmd { - #allow arbitrary - review - set cmd_info [dict merge $cmd_info $at_specs] - } - doc { - set doc_info [dict merge $doc_info $at_specs] - } - argdisplay { - #override the displayed argument table. - #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing - set argdisplay_info [dict merge $argdisplay_info $at_specs] - } - opts { - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "values"} { - error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" - } - dict set F $fid argspace "options" - set tmp_optspec_defaults [dict get $F $fid optspec_defaults] - - foreach {k v} $at_specs { - switch -- $k { - -any - - -anyopts { - set opt_any $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { - #review - only apply to certain types? - tcl::dict::set tmp_optspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_optspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - none - "" - - - any - ansistring - globstring - list { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_optspec_defaults -type $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - #allow overriding of defaults for options that occur later - tcl::dict::set tmp_optspec_defaults $k $v - } - default { - set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" - } - } - } - dict set F $fid optspec_defaults $tmp_optspec_defaults - } ;# end foreach record_form_ids - } - leaders { - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] in [list options values]} { - error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" - } - set tmp_leaderspec_defaults [dict get $F $fid leaderspec_defaults] - - foreach {k v} $at_specs { - switch -- $k { - -min - - -minvalues { - if {$v < 0} { - error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MIN $v - #if {$leader_max == 0} { - # set leader_max -1 - #} - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MAX $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -choiceinfo { - if {[llength $v] %2 != 0} { - error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - #-choicegroups? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_leaderspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set tmp_leaderspec_defaults $k $v - } - default { - set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid leaderspec_defaults $tmp_leaderspec_defaults - - } ;#end foreach record_form_ids - - } - values { - foreach fid $record_form_ids { - dict set F $fid argspace "values" - - set tmp_valspec_defaults [dict get $F $fid valspec_defaults] - - foreach {k v} $at_specs { - switch -- $k { - -form { - } - -min - - -minvalues { - if {$v < 0} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" - } - set val_min $v - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" - } - set val_max $v - } - -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_valspec_defaults $k $v - } - -choiceinfo - -choicegroups { - if {[llength $v] % 2 != 0} { - error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - # -choicegroups ?? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_valspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set tmp_valspec_defaults $k $v - } - default { - set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid valspec_defaults $tmp_valspec_defaults - } - - } - seealso { - #todo! - #like @doc, except displays in footer, multiple - sub-table? - set seealso_info [dict merge $seealso_info $at_specs] - } - keywords { - #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? - set keywords_info [dict merge $keywords_info $at_specs] - } - default { - error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @argdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" - } - } - #record_type directive - continue - } elseif {$firstchar eq "-"} { - set argname $firstword - set argdef_values $record_values - tcl::dict::set argdef_values -ARGTYPE option - - - - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - dict set F $fid argspace "options" - } elseif {[dict get $F $fid argspace] eq "values"} { - error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" - } - set record_type option - dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] - #lappend opt_names $argname - } - - set is_opt 1 - } else { - set argname $firstword - if {$firstchar eq "@"} { - #allow basic @@ escaping for literal argname that begins with @ - set argname [tcl::string::range $argname 1 end] - } - - set argdef_values $record_values - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - set record_type leader - tcl::dict::set argdef_values -ARGTYPE leader - #lappend leader_names $argname - set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] - if {$argname ni $temp_leadernames} { - lappend temp_leadernames $argname - tcl::dict::set F $fid LEADER_NAMES $temp_leadernames - } else { - error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" - } - - if {[dict get $F $fid LEADER_MAX] >= 0} { - dict set F $fid LEADER_MAX [llength $temp_leadernames] - } - } else { - set record_type value - tcl::dict::set argdef_values -ARGTYPE value - set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] - lappend temp_valnames $argname - tcl::dict::set F $fid VAL_NAMES $temp_valnames - #lappend val_names $argname - } - } - - set is_opt 0 - } - - - #assert - we only get here if it is a value or flag specification line. - #assert argdef_values has been set to the value of record_values - - foreach fid $record_form_ids { - if {$is_opt} { - set spec_merged [dict get $F $fid optspec_defaults] - } else { - if {[dict get $F $fid argspace] eq "values"} { - set spec_merged [dict get $F $fid valspec_defaults] - } else { - set spec_merged [dict get $F $fid leaderspec_defaults] - } - } - - # -> argopt argval - foreach {spec specval} $argdef_values { - #literal-key switch - bytecompiled to jumpTable - switch -- $spec { - -form { - - } - -type { - #normalize here so we don't have to test during actual args parsing in main function - switch -- [tcl::string::tolower $specval] { - int - integer { - tcl::dict::set spec_merged -type int - } - bool - boolean { - tcl::dict::set spec_merged -type bool - } - char - character { - tcl::dict::set spec_merged -type char - } - dict - dictionary { - tcl::dict::set spec_merged -type dict - } - "" - none { - if {$is_opt} { - tcl::dict::set spec_merged -type none - 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 - error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" - } - } - any - anything { - tcl::dict::set spec_merged -type any - } - ansi - ansistring { - tcl::dict::set spec_merged -type ansistring - } - any - string - globstring { - tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - } - default { - #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW - tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - } - } - } - -default - -solo - -range - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo - - -minsize - -maxsize - -nocase - -optional - -multiple - - -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - - -regexprepass - -regexprefail - -regexprefailmsg - { - #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines - #review -solo 1 vs -type none ? conflicting values? - tcl::dict::set spec_merged $spec $specval - } - -validationtransform { - #string is dict only 8.7/9+ - if {[llength $specval] % 2} { - error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" - } - dict for {tk tv} $specval { - switch -- $tk { - -function - -type - -minsize - -maxsize - -range { - } - default { - set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? - error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" - } - } - } - - } - default { - if {[string match ref-* $spec]} { - #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) - #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. - if {![tcl::dict::exists $refs $specval]} { - puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" - } else { - set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" - if {$targetswitch eq "-*"} { - set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id - } else { - if {[tcl::dict::exists $refs $specval $targetswitch]} { - tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] - } else { - puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" - } - } - } - } else { - set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - ] - error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" - } - } - } - } ;# end foreach {spec specval} argdef_values - - - if {$is_opt} { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } else { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - tcl::dict::set F $fid ARG_INFO $argname $spec_merged - #review existence of -default overriding -optional - if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { - if {$is_opt} { - lappend opt_required $argname - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - set temp_leader_required [dict get $F $fid LEADER_REQUIRED] - lappend temp_leader_required $argname - dict set F $fid LEADER_REQUIRED $temp_leader_required - #lappend leader_required $argname - } else { - lappend val_required $argname - } - } - } - if {[tcl::dict::exists $spec_merged -default]} { - if {$is_opt} { - tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } else { - tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] - } - } - } - } ;# end foreach fid record_form_ids - - } ;# end foreach rec $records - - - #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { - # variable id_counter - # set DEF_definition_id "autoid_[incr id_counter]" - #} - - - #check ALL forms not just form_ids_active (record_form_ids) - dict for {fid formdata} $F { - # REVIEW - #no values specified - we can allow last leader to be multiple - foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { - error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" - } - } - #confirm any valnames before last don't have -multiple key - foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { - error "bad key -multiple on argument spec for value '$valname' in command form:'$fid'. Only the last value argument specification can be marked -multiple @id:$DEF_definition_id" - } - } - - #todo - document that ambiguities in API are likely if both @leaders and @values used - #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) - - - dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - - - - - #todo - precalculate a set of 'arity' entries for each form - #We want a structure for the arg parser to get easy access and make a fast decision on which form applies - #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? - #1) after ms (1 1) - #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? - #3) after cancel id (2 2) - #4) after cancel script ?script...? (2 -1) - #5) after idle script ?script...? (1 -1) - #6) after info ?id? (1 2) - - #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) - - #in the above case we have no unique total_arity - #we would also want to consider values when selecting - #e.g given the invalid command "after cancel" - # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. - - - - set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands - #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use - #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form - #e.g commandline completion could show list of synopsis entries to select from - - set form_info [dict create] - dict for {fid fdict} $F { - dict set form_info $fid {} - dict for {optk optv} $fdict { - if {[string match -* $optk]} { - dict set form_info $fid $optk $optv - } - } - } - - set argdata_dict [tcl::dict::create\ - id $DEF_definition_id\ - ARG_INFO [dict get $F $firstformid ARG_INFO]\ - ARG_CHECKS [dict get $F $firstformid ARG_CHECKS]\ - LEADER_DEFAULTS [dict get $F $firstformid LEADER_DEFAULTS]\ - LEADER_REQUIRED [dict get $F $firstformid LEADER_REQUIRED]\ - LEADER_NAMES [dict get $F $firstformid LEADER_NAMES]\ - LEADER_MIN [dict get $F $firstformid LEADER_MIN]\ - LEADER_MAX [dict get $F $firstformid LEADER_MAX]\ - leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ - LEADER_CHECKS_DEFAULTS [dict get $F $firstformid LEADER_CHECKS_DEFAULTS]\ - opt_defaults $opt_defaults\ - opt_required $opt_required\ - OPT_NAMES [dict get $F $firstformid OPT_NAMES]\ - opt_any $opt_any\ - opt_solos $opt_solos\ - optspec_defaults [dict get $F $firstformid optspec_defaults]\ - OPT_CHECKS_DEFAULTS [dict get $F $firstformid OPT_CHECKS_DEFAULTS]\ - val_defaults $val_defaults\ - val_required $val_required\ - VAL_NAMES [dict get $F $firstformid VAL_NAMES]\ - val_min $val_min\ - val_max $val_max\ - valspec_defaults [dict get $F $firstformid valspec_defaults]\ - VAL_CHECKS_DEFAULTS [dict get $F $firstformid VAL_CHECKS_DEFAULTS]\ - cmd_info $cmd_info\ - doc_info $doc_info\ - package_info $package_info\ - argdisplay_info $argdisplay_info\ - seealso_info $seealso_info\ - id_info $id_info\ - FORMS $F\ - form_names [dict keys $F]\ - FORM_INFO $form_info\ - ] - - tcl::dict::set argdata_cache $cache_key $argdata_dict - if {$is_dynamic} { - #also cache resolved version - tcl::dict::set argdata_cache $optionspecs $argdata_dict - } - - #tcl::dict::set id_cache_rawdef $DEF_definition_id $args - #puts "xxx:$result" - return $argdata_dict - } - - #return raw definition list as created with 'define' - # - possibly with unresolved dynamic parts - proc raw_def {id} { - variable id_cache_rawdef - set realid [real_id $id] - if {![dict exists $id_cache_rawdef $realid]} { - return "" - } - return [tcl::dict::get $id_cache_rawdef $realid] - } - - - namespace eval argdoc { - variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @argdisplay @seealso @leaders @opts @values leaders opts values} - variable resolved_def_TYPE_CHOICEGROUPS { - directives {@id @package @cmd @ref @doc @argdisplay @seealso} - argumenttypes {leaders opts values} - remaining_defaults {@leaders @opts @values} - } - - lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { - @id -id ::punk::args::resolved_def - @cmd -name punk::args::resolved_def -help\ - "Resolves or retrieves the previously resolved definition and - uses the 'spec' form to build a response in definition format. - - Pulling argument definition data from another function is a form - of tight coupling to the other function that should be done with - care. - - Note that the directives @leaders @opts @values may appear multiple - times in a source definition - applying defaults for arguments that - follow. When retrieving these - there is only a single result for - each that represents the defaults after all have been applied. - When retrieving -types * each of these will be positioned before - the arguments of that type - but this doesn't mean there was a single - leading directive for this argument type in the source definition. - Each argument has already had its complete specification recorded in - its own result. - - When manually specifying -types, the order @leaders then @opts then - @values must be maintained - but if they are placed before their - corresponding arguments, they will not affect the retrieved arguments - as these arguments are already fully spec'd. The defaults from the - source can be removed by adding @leaders, @opts @values to the - -antiglobs list, but again - this won't affect the existing arguments. - Each argument can have members of its spec overridden using the - -override dictionary. - " - @leaders -min 0 -max 0 - @opts - -return -default text -choices {text dict} - -form -default 0 -help\ - "Ordinal index or name of command form" - - #no restriction on number of types/repetitions? - -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} - -antiglobs -default {} -type list -help\ - "Glob patterns for directive or argument/flags to - be suppressed" - -override -type dict -optional 1 -default "" -help\ - "dict of dicts. Key in outer dict is the name of a - directive or an argument. Inner dict is a map of - overrides/additions (- ...) for that line. - " - @values -min 1 -max -1 - id -type string -help\ - "identifer for a punk::args definition - This will usually be a fully-qualifed - path for a command name" - pattern -type string -optional 1 -default * -multiple 1 -help\ - "glob-style patterns for retrieving value or switch - definitions. - - If -type is * and pattern is * the entire definition including - directive lines will be returned in line form. - (directives are lines beginning with - @ e.g @id, @cmd etc) - - if -type is leaders,opts or values matches from that type - will be returned. - - if -type is another directive such as @id, @doc etc the - patterns are ignored. - - " - }]] - } - - - proc resolved_def {args} { - #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. - set opts [dict create\ - -return text\ - -types {}\ - -form 0\ - -antiglobs {}\ - -override {}\ - ] - if {[llength $args] < 1} { - #must have at least id - punk::args::parse $args withid ::punk::args::resolved_def - return - } - set patterns [list] - - #a definition id must not begin with "-" ??? review - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {$a in {-type -types}} { - incr i - dict set opts -types [lindex $args $i] - } elseif {[string match -* $a]} { - incr i - dict set opts $a [lindex $args $i] - } else { - set id [lindex $args $i] - set patterns [lrange $args $i+1 end] - break - } - if {$i == [llength $args]-1} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - if {![llength $patterns]} { - set patterns [list *] - } - dict for {k v} $opts { - switch -- $k { - -return - -form - -types - -antiglobs - -override {} - default { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - } - set typelist [dict get $opts -types] - if {[llength $typelist] == 0} { - set typelist {*} - } - foreach type $typelist { - if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - - - variable id_cache_rawdef - set realid [real_id $id] - if {$realid eq ""} { - return - } - - set deflist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] - - set opt_form [dict get $opts -form] - if {[string is integer -strict $opt_form]} { - set formname [lindex [dict get $specdict form_names] $opt_form] - } else { - set formname $opt_form - } - set opt_override [dict get $opts -override] - set opt_return [dict get $opts -return] - - #set arg_info [dict get $specdict ARG_INFO] - set arg_info [dict get $specdict FORMS $formname ARG_INFO] - set argtypes [dict create leaders leader opts option values value] - - set opt_antiglobs [dict get $opts -antiglobs] - set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] - set suppressed_directives [list] - set suppressed_args [list] - foreach ag $opt_antiglobs { - foreach d $directives { - if {[string match $ag $d]} { - lappend suppressed_directives $d - } - } - foreach argname [dict keys $arg_info] { - if {[string match $ag $argname]} { - lappend suppressed_args $argname - } - } - } - set suppressed_directives [lsort -unique $suppressed_directives] - set suppressed_args [lsort -unique $suppressed_args] - - set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] - - set globbed [list] - foreach pat $patterns { - set matches [dict keys $arg_info $pat] - lappend globbed {*}$matches - } - set globbed [lsort -unique $globbed] - set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args] - - set result "" - set resultdict [dict create] - foreach type $typelist { - switch -exact -- $type { - * { - if {"@id" in $included_directives} { - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - foreach directive {@package @cmd @doc @seealso @argdisplay} { - set dshort [string range $directive 1 end] - if {"$directive" in $included_directives} { - if {[dict exists $opt_override $directive]} { - append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict ${dshort}_info]" - dict set resultdict $directive [dict get $specdict ${dshort}_info] - } - } - } - #output ordered by leader, option, value - foreach pseudodirective {leaders opts values} tp {leader option value} { - set directive "@$pseudodirective" - switch -- $directive { - @leaders {set defaults_key leaderspec_defaults} - @opts {set defaults_key optspec_defaults} - @values {set defaults_key valspec_defaults} - } - - if {"$directive" in $included_directives} { - if {[dict exists $opt_override "$directive"]} { - append result \n "$directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict $defaults_key]" - dict set resultdict $directive [dict get $specdict $defaults_key] - } - } - - if {$pseudodirective in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq $tp} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "$m $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - - } - @id { - if {"@id" in $included_directives} { - #only a single id record can exist - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - } - @package - @cmd - @doc - @seealso - @argdisplay { - if {"$type" in $included_directives} { - set tp [string range $type 1 end] ;# @package -> package - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict ${tp}_info]" - dict set resultdict $type [dict get $specdict ${tp}_info] - } - } - } - @leaders - @opts - @values { - #these are the active defaults for further arguments - if {"$type" in $included_directives} { - switch -- $type { - @leaders {set defaults_key leaderspec_defaults} - @opts {set defaults_key optspec_defaults} - @values {set defaults_key valspec_defaults} - } - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict leaderspec_defaults]" - dict set resultdict $type [dict get $specdict leaderspec_defaults] - } - } - } - leaders - opts - values { - #pseudo-directives - if {$type in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "$m $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - default { - } - } - if {$opt_return eq "text"} { - return $result - } else { - return $resultdict - } - } - } - - proc resolved_def_values {id {patternlist *}} { - variable id_cache_rawdef - set realid [real_id $id] - if {$realid ne ""} { - set speclist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [resolve {*}$speclist] - set arg_info [dict get $specdict ARG_INFO] - set valnames [dict get $specdict VAL_NAMES] - set result "" - if {$patternlist eq "*"} { - foreach v $valnames { - set def [dict get $arg_info $v] - set def [dict remove $def -ARGTYPE] - append result \n "$v $def" - } - return $result - } else { - foreach pat $patternlist { - set matches [dict keys $arg_info $pat] - set matches [lsearch -all -inline -glob $valnames $pat] - foreach m $matches { - set def [dict get $arg_info $m] - set def [dict remove $def -ARGTYPE] - append result \n "$m $def" - } - } - return $result - } - } - } - #proc resolved_def_leaders ?? - #proc resolved_def_opts ?? - - proc get_spec {id} { - set rdef [raw_def $id] - if {$rdef eq ""} {return} - return [resolve {*}$rdef] - #if {[id_exists $id]} { - # return [resolve {*}[raw_def $id]] - #} - } - proc is_dynamic {id} { - variable id_cache_rawdef - variable rawdef_cache - set deflist [raw_def $id] - if {[dict exists $rawdef_cache $deflist -dynamic]} { - return [dict get $rawdef_cache $deflist -dynamic] - } - return [rawdef_is_dynamic $deflist] - #@dynamic only has meaning as 1st element of a def in the deflist - } - - #@id must be within first 4 lines of a block - or assign auto - #review - @dynamic block where -id not explicitly set? - disallow? - proc rawdef_id {rawdef} { - set id "" - foreach d $rawdef { - foreach ln [lrange [split $d \n] 0 4] { - if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { - if {$firstword eq "@id"} { - if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { - set id [dict get $rest -id] - break - } - } - } - } - if {$id ne ""} { - break - } - } - if {$id eq "" || [string tolower $id] eq "auto"} { - variable id_counter - set id "autoid_[incr id_counter]" - } - #puts "==>id: $id" - return $id - } - #test the rawdef for @dynamic directive - proc rawdef_is_dynamic {rawdef} { - #temporary - old way - set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] - if {$flagged_dynamic} { - return true - } - foreach d $rawdef { - if {[regexp {\s*(\S+)} $d _match firstword]} { - if {$firstword eq "@dynamic"} { - return true - } - } - } - return false - } - - variable aliases - set aliases [dict create] - - lappend PUNKARGS [list { - @id -id ::punk::args::get_ids - @cmd -name punk::args::get_ids -help\ - "return list of ids for argument definitions" - @values -min 0 -max 1 - match -default * -help\ - "exact id or glob pattern for ids" - }] - proc get_ids {{match *}} { - variable id_cache_rawdef - variable aliases - return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] - } - - #we don't automatically test for (autodef)$id - only direct ids and aliases - proc id_exists {id} { - variable aliases - if {[tcl::dict::exists $aliases $id]} { - return 1 - } - variable id_cache_rawdef - tcl::dict::exists $id_cache_rawdef $id - } - proc set_alias {alias id} { - variable aliases - dict set aliases $alias $id - } - proc unset_alias {alias} { - variable aliases - dict unset aliases $alias - } - proc get_alias {alias} { - variable aliases - if {[dict exists $aliases $alias]} { - return [tcl::dict::get $aliases $alias] - } - } - - proc real_id {id} { - variable id_cache_rawdef - variable aliases - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } else { - set check_updates [list [namespace qualifiers $id]] - if {![llength [update_definitions $check_updates]]} { - #nothing new loaded - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } else { - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } - } - } - - proc status {} { - upvar ::punk::args::register::NAMESPACES registered - upvar ::punk::args::register::loaded_packages loaded_packages - upvar ::punk::args::register::loaded_info loaded_info - upvar ::punk::args::register::scanned_packages scanned_packages - upvar ::punk::args::register::scanned_info scanned_info - set result "" - # [format %-${w0}s $idtail] - set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] - append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n - set width_c2 [string length "Scanned_ids"] - set width_c3 [string length "Scantime_us"] - set width_c4 [string length "Loaded_defs"] - set width_c5 [string length "Loadtime_us"] - set count_unloaded 0 - set count_loaded 0 - foreach ns $registered { - if {$ns in $scanned_packages} { - set ids [dict get $scanned_info $ns idcount] - set scan_us [dict get $scanned_info $ns time] - } else { - set ids "" - set scan_us "" - } - if {$ns in $loaded_packages} { - incr count_loaded - set ldefs [dict get $loaded_info $ns defcount] - set load_us [dict get $loaded_info $ns time] - } else { - incr count_unloaded - set ldefs "" - set load_us "" - } - append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n - } - append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" - return $result - } - - #scanned_packages (list) - #namespace_docpackages (dict) - proc update_definitions {{nslist *}} { - if {[set gposn [lsearch $nslist {}]] >= 0} { - lset nslist $gposn :: - } - upvar ::punk::args::register::NAMESPACES registered ;#list - upvar ::punk::args::register::loaded_packages loaded_packages ;#list - upvar ::punk::args::register::loaded_info loaded_info ;#dict - upvar ::punk::args::register::scanned_packages scanned_packages ;#list - upvar ::punk::args::register::scanned_info scanned_info ;#dict - upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict - - - #puts stderr "-->update_definitions '$nslist'" - #needs to run quickly - especially when no package namespaces to be scanned for argdefs - #e.g - gets called for each subcommand of an ensemble (could be many) - # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. - #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. - # -- --- --- --- --- --- - # common-case fast-path - - if {[llength $loaded_packages] == [llength $registered]} { - #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. - #assert - if all are registered - then all have been scanned ( - return {} - } - # -- --- --- --- --- --- - - set unscanned [punklib_ldiff $registered $scanned_packages] - if {[llength $unscanned]} { - foreach pkgns $unscanned { - set idcount 0 - set ts_start [clock microseconds] - if {[info exists ${pkgns}::PUNKARGS]} { - set seen_documentedns [list] ;#seen per pkgns - foreach definitionlist [set ${pkgns}::PUNKARGS] { - #namespace eval $evalns [list punk::args::define {*}$definitionlist] - set id [rawdef_id $definitionlist] - if {[string match autoid_* $id]} { - puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" - puts stderr "definition:\n" - foreach d $definitionlist { - set out "" - foreach ln [split $d \n] { - append out " " $ln \n - } - puts $out - } - continue - } - #todo - detect duplicate ids (last will silently win.. should be reported somewhere) - incr idcount - set documentedns [namespace qualifiers $id] - if {$documentedns eq ""} {set documentedns ::} - if {$documentedns ni $seen_documentedns} { - #don't add own ns as a key in namespace_docpackages - if {$documentedns ne $pkgns} { - dict lappend namespace_docpackages $documentedns $pkgns - } - lappend seen_documentedns $documentedns - } - } - } - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - dict set scanned_info $pkgns [dict create time $diff idcount $idcount] - #we count it as scanned even if PUNKARGS didn't exist - #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) - lappend scanned_packages $pkgns - } - } - - - - if {"*" in $nslist} { - set needed [punklib_ldiff $registered $loaded_packages] - } else { - set needed [list] - foreach pkgns $nslist { - if {$pkgns in $registered && $pkgns ni $loaded_packages} { - lappend needed $pkgns - } - #argdoc sub namespace is a standard place to put defs that match the namespace below - #(generally the PUNKARGS in a namespace should apply to own ns) - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { - lappend needed $docns - } - } - if {[dict exists $namespace_docpackages $pkgns]} { - #this namespace has other argdef sources - foreach docns [dict get $namespace_docpackages $pkgns] { - if {$docns ni $loaded_packages} { - lappend needed $docns - } - } - } - } - } - - - - set newloaded [list] - foreach pkgns $needed { - #puts stderr "update_definitions Loading: $pkgns" - set ts_start [clock microseconds] - set def_count 0 - if {![catch { - if {[info exists ${pkgns}::PUNKARGS]} { - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - namespace eval ${pkgns}::argdoc { - set epath [namespace path] - set pkgns [namespace parent] - if {$pkgns ni $epath} { - namespace path [list {*}$epath $pkgns] ;#add to tail - } - - } - set evalns $docns - } else { - set evalns $pkgns - } - foreach definitionlist [set ${pkgns}::PUNKARGS] { - namespace eval $evalns [list punk::args::define {*}$definitionlist] - incr def_count - } - } - - #process list of 2-element lists - if {[info exists ${pkgns}::PUNKARGS_aliases]} { - foreach adef [set ${pkgns}::PUNKARGS_aliases] { - punk::args::set_alias {*}$adef - } - } - } errMsg]} { - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - lappend loaded_packages $pkgns - lappend newloaded $pkgns - dict set loaded_info $pkgns [dict create time $diff defcount $def_count] - } else { - puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" - } - } - return $newloaded - } - - #for use within get_dict only - #This mechanism gets less-than-useful results for oo methods - #e.g {$obj} - proc Get_caller {} { - #set call_level -3 ;#for get_dict call - set call_level -4 - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - #puts "-->$cmdinfo" - #puts "-->[tcl::info::frame -3]" - while {[string last \n $cmdinfo] >= 1} { - #looks like a script - haven't gone up far enough? - #(e.g patternpunk oo system: >punk . poses -invalidoption) - incr call_level -1 - if {[catch { - set nextup [tcl::info::frame $call_level] - } ]} { - break - } - set cmdinfo [tcl::dict::get $nextup cmd] - set caller [regexp -inline {\S+} $cmdinfo] - if {[interp alias {} $caller] ne ""} { - #puts "found alias for caller $caller to [interp alias {} $caller]" - #see if we can go further - incr call_level -1 - if {[catch { - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - } errM ]} { - puts "err: $errM" - break - } - } - } - set caller [regexp -inline {\S+} $cmdinfo] - if {$caller eq "namespace"} { - # review - message? - set cmdinfo "punk::args::get_dict called from namespace" - } - return $cmdinfo - } - - - # -------------------------------------- - #test of Get_caller - lappend PUNKARGS [list { - @id -id ::punk::args::test1 - @values -min 0 -max 0 - }] - proc test_get_dict {args} { - punk::args::get_dict {*}[punk::args::raw_def ::punk::args::test1] $args - } - proc test_get_by_id {args} { - punk::args::get_by_id ::punk::args::test1 $args - } - #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. - proc test_callers {args} { - if {![llength $args]} { - puts "these test functions accept no arguments" - puts "Call with arg(s) to compare error output" - } - - if {[catch {test_get_dict {*}$args} errM]} { - puts $errM - } - puts "------------" - if {[catch {test_get_by_id {*}$args} errM]} { - puts $errM - } - return done - } - # -------------------------------------- - - set map "" - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::arg_error - @cmd -name punk::args::arg_error -help\ - "Generates a table (by default) of usage information for a command. - A trie system is used to create highlighted prefixes for command - switches and for subcommands or argument/switch values that accept - a defined set of choices. These prefixes match the mechanism used - to validate arguments (based on tcl::prefix::match). - - This function is called during the argument parsing process - (if the definition is not only being used for documentation) - It is also called by punk::args::usage which is in turn - called by the punk::ns introspection facilities which creates - on the fly definitions for some commands such as ensembles and - oo objects where a manually defined one isn't present. - " - @leaders -min 2 -max 2 - msg -type string -help\ - "Error message to display immediately prior to usage table. - May be empty string to just display usage. - " - spec_dict -type dict -help\ - "Dictionary of argument specifications. - This is the internal format parsed from - the textual definition. It contains the data - organised/optimised to allow the final arg - parser/validator to make decisions. - " - @opts - -badarg -type string -help\ - "name of an argument to highlight" - -aserror -type boolean -help\ - "If true, the usage table is raised as an error message, - otherwise it is returned as a value." - -return -choices {string table tableobject} -choicelabels { - string "no table layout" - tableobject "table object cmd" - table "full table laout" - } - -scheme -default error -choices {nocolour info error} - }] ] - - #basic recursion blocker - variable arg_error_isrunning 0 - proc arg_error {msg spec_dict args} { - #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. - #accept an option here so that we can still use full output for usage requests. - #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args - #Development/experimentation may be done with full table-based error reporting - but for production release it - #may be desirable to reduce overhead on catches. - #consider per-namespace or namespace-tree configurability. - #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due - #to resource availability etc - so the slower error generation time may not always be a problem. - #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling - #code which has no use for the enhanced error info. - #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. - #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system - #todo - #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error - #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) - - #todo - document unnamed leaders and unnamed values where -min and/or -max specified - #e.g punk::args::get_dict {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} {} - #only |?-x?|string|... is shown in the output table. - #should be something like: - # |arg | - # |?-x? | - # |arg | - # |?arg...?| - # Where/how to specify counts? - #also.. - # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? - # - - - if {[catch {package require punk::ansi}]} { - proc punk::args::a {args} {} - proc punk::args::a+ {args} {} - } else { - namespace eval ::punk::args { - namespace import ::punk::ansi::a ::punk::ansi::a+ - } - } - #limit colours to standard 16 so that themes can apply to help output - variable arg_error_isrunning - if {$arg_error_isrunning} { - error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" - } - - if {[llength $args] %2 != 0} { - error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" - } - - set arg_error_isrunning 1 - - set badarg "" - set returntype table ;#table as string - set as_error 1 ;#usual case is to raise an error - set scheme error - dict for {k v} $args { - set fullk [tcl::prefix::match -error "" {-badarg -aserror -return -scheme} $k] - switch -- $fullk { - -badarg { - set badarg $v - } - -aserror { - if {![string is boolean -strict $v]} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" - } - set as_error $v - } - -scheme { - set scheme $v - } - -return { - if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" - } - set returntype $v - } - default { - set arg_error_isrunning 0 - error "arg_error invalid option $k. Known_options: -badarg -return -aserror" - } - } - } - #todo - scheme - use config and iterm toml definitions etc - switch -- $scheme { - "" - -nocolor - -nocolour { - set scheme nocolour - } - info - error {} - default { - set scheme na - } - } - #hack some basics for now. - #for coloured schemes - use bold as well as brightcolour in case colour off. - array set CLR {} - set CLR(errormsg) [a+ brightred] - set CLR(title) "" - set CLR(check) [a+ brightgreen] - set CLR(solo) [a+ brightcyan] - set CLR(choiceprefix) [a+ underline] - set CLR(badarg) [a+ brightred] - set CLR(linebase_header) [a+ white] - set CLR(cmdname) [a+ brightwhite] - set CLR(groupname) [a+ bold] - set CLR(ansiborder) [a+ bold] - set CLR(ansibase_header) [a+ bold] - set CLR(ansibase_body) [a+ white] - - switch -- $scheme { - nocolour { - set CLR(errormsg) [a+ bold] - set CLR(title) [a+ bold] - set CLR(check) "" - set CLR(solo) "" - set CLR(badarg) [a+ reverse] ;#? experiment - set CLR(cmdname) [a+ bold] - set CLR(linebase_header) "" - set CLR(linebase) "" - set CLR(ansibase_body) "" - } - info { - set CLR(errormsg) [a+ brightred bold] - set CLR(title) [a+ brightyellow bold] - set CLR(check) [a+ brightgreen bold] - set CLR(choiceprefix) [a+ brightgreen bold] - set CLR(groupname) [a+ cyan bold] - set CLR(ansiborder) [a+ brightcyan bold] - set CLR(ansibase_header) [a+ cyan] - set CLR(ansibase_body) [a+ white] - } - error { - set CLR(errormsg) [a+ brightred bold] - set CLR(title) [a+ brightcyan bold] - set CLR(check) [a+ brightgreen bold] - set CLR(choiceprefix) [a+ brightgreen bold] - set CLR(groupname) [a+ cyan bold] - set CLR(ansiborder) [a+ brightyellow bold] - set CLR(ansibase_header) [a+ yellow] - set CLR(ansibase_body) [a+ white] - } - na { - } - } - - - #set RST [a] - set RST "\x1b\[m" - set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. - - #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error - #e.g list_as_table - - # use basic colours here to support terminals without extended colours - #todo - add checks column (e.g -minsize -maxsize) - set errmsg $msg - if {![catch {package require textblock}]} { - set has_textblock 1 - } else { - set has_textblock 0 - #couldn't load textblock package - #just return the original errmsg without formatting - } - set use_table 0 - if {$has_textblock && $returntype in {table tableobject}} { - set use_table 1 - } - set errlines [list] ;#for non-textblock output - if {[catch { - if {$use_table} { - append errmsg \n - } else { - if {($returntype in {table tableobject}) && !$has_textblock} { - append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n - } else { - append errmsg \n - } - } - set cmdname [Dict_getdef $spec_dict cmd_info -name ""] - set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] - - set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] - set docurl [Dict_getdef $spec_dict doc_info -url ""] - - set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] - set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] - if {"$argdisplay_header$argdisplay_body" eq ""} { - set is_custom_argdisplay 0 - } else { - set is_custom_argdisplay 1 - } - - - set blank_header_col [list] - if {$cmdname ne ""} { - lappend blank_header_col "" - set cmdname_display $CLR(cmdname)$cmdname$RST - } else { - set cmdname_display "" - } - if {$cmdhelp ne ""} { - lappend blank_header_col "" - #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] - set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] - } else { - set cmdhelp_display "" - } - if {$docurl ne ""} { - lappend blank_header_col "" - set docurl_display [a+ white]$docurl$RST - } else { - set docurl_display "" - } - #synopsis - set synopsis "" - set form_info [dict get $spec_dict FORM_INFO] - dict for {fid finfo} $form_info { - set syn [Dict_getdef $finfo -synopsis ""] - if {$syn ne ""} { - append synopsis $syn \n - } - } - if {$synopsis ne ""} { - set synopsis [string range $synopsis 0 end-1] - lappend blank_header_col "" - } - - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - if {$use_table} { - set t [textblock::class::table new "$CLR(title)Usage$RST"] - $t add_column -headers $blank_header_col -minwidth 3 - $t add_column -headers $blank_header_col - - if {!$is_custom_argdisplay} { - lappend blank_header_col "" - #spanned columns in default argdisplay area - $t add_column -headers $blank_header_col ;#Default - $t add_column -headers $blank_header_col ;#Multi - $t add_column -headers $blank_header_col ;#Help - set arg_colspans {1 4 0 0 0} - } else { - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - set arg_colspans {1 1} - } - } - set h 0 - if {$cmdname ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] - } else { - lappend errlines "COMMAND: $cmdname_display" - } - incr h - } - if {$cmdhelp ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] - } else { - lappend errlines "Description: $cmdhelp_display" - } - incr h - } - if {$docurl ne ""} { - if {![catch {package require punk::ansi}]} { - set docurl [punk::ansi::hyperlink $docurl] - } - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] - } else { - lappend errlines "$docname $docurl_display" - } - incr h - } - if {$synopsis ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Synopsis: $synopsis] - } else { - #todo - lappend errlines "Synopsis:\n$synopsis" - } - incr h - } - - - if {$use_table} { - if {$is_custom_argdisplay} { - if {$argdisplay_header ne ""} { - $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] - } - } else { - $t configure_header $h -values {Arg Type Default Multi Help} - } - } else { - lappend errlines " --ARGUMENTS-- " - } - - if {$is_custom_argdisplay} { - if {$use_table} { - #using overall container table - #header already added - #TODO - review textblock::table features - #we can't currently span columns within the table body. - #This feature could allow hidden data columns (and sort on hidden col?) - #potentially require coordination with header colspans? - $t add_row [list "" $argdisplay_body] - } else { - if {$argdisplay_header ne ""} { - lappend errlines $argdisplay_header - } - lappend errlines {*}$argdisplay_body - } - } else { - - #set A_DEFAULT [a+ brightwhite Brightgreen] - set A_DEFAULT "" - set A_BADARG $CLR(badarg) - set greencheck $CLR(check)\u2713$RST ;#green tick - set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply - if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { - #A_PREFIX can resolve to empty string if colour off - #we then want to display underline instead - set A_PREFIX [a+ underline] - set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space - } else { - set A_PREFIXEND $RST - } - - set opt_names [list] - set opt_names_display [list] - if {[llength [dict get $spec_dict OPT_NAMES]]} { - if {![catch {package require punk::trie}]} { - set trie [punk::trie::trieclass new {*}[dict get $spec_dict OPT_NAMES]] - set idents [dict get [$trie shortest_idents ""] scanned] - #todo - check opt_prefixdeny - - $trie destroy - foreach c [dict get $spec_dict OPT_NAMES] { - set id [dict get $idents $c] - #REVIEW - if {$id eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $id] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail - #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] - lappend opt_names $c - } - } else { - set opt_names [dict get $spec_dict OPT_NAMES] - set opt_names_display $opt_names - } - } - set leading_val_names [dict get $spec_dict LEADER_NAMES] - set trailing_val_names [dict get $spec_dict VAL_NAMES] - - #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { - # if {![string match -* $argname]} { - # lappend leading_val_names [lpop trailing_val_names 0] - # } else { - # break - # } - #} - #if {![llength $leading_val_names] && ![llength $opt_names]} { - # #all vals were actually trailing - no opts - # set trailing_val_names $leading_val_names - # set leading_val_names {} - #} - set leading_val_names_display $leading_val_names - set trailing_val_names_display $trailing_val_names - - #display options first then values - foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { - lassign $argumentset argnames_display argnames - - foreach argshow $argnames_display arg $argnames { - set arginfo [dict get $spec_dict ARG_INFO $arg] - if {[dict exists $arginfo -default]} { - set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" - } else { - set default "" - } - set help [Dict_getdef $arginfo -help ""] - set allchoices_originalcase [list] - set choices [Dict_getdef $arginfo -choices {}] - set choicegroups [Dict_getdef $arginfo -choicegroups {}] - set choicemultiple [dict get $arginfo -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] - set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] - if {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - set is_multiple 1 - } else { - set multiple "" - set is_multiple 0 - } - if {[dict exists $choicegroups ""]} { - dict lappend choicegroups "" {*}$choices - } else { - set choicegroups [dict merge [dict create "" $choices] $choicegroups] - } - dict for {groupname clist} $choicegroups { - lappend allchoices_originalcase {*}$clist - } - set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] - - if {$has_choices} { - if {$help ne ""} {append help \n} - if {[dict get $arginfo -nocase]} { - set casemsg " (case insensitive)" - set allchoices_test [string tolower $allchoices_originalcase] - } else { - set casemsg " (case sensitive)" - set allchoices_test $allchoices_originalcase - } - if {[dict get $arginfo -choiceprefix]} { - set prefixmsg " (choice prefix allowed)" - } else { - set prefixmsg "" - } - set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] - set formattedchoices [dict create] ;#use dict rather than array to preserve order - append help " Choices$prefixmsg$casemsg" - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - if {$choicemultiple_max == -1} { - append help \n " The value can be a list of $choicemultiple_min or more of these choices" - } else { - if {$choicemultiple_min eq $choicemultiple_max} { - append help \n " The value must be a list of $choicemultiple_min of these choices" - } else { - append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" - } - } - } - if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set cdisplay $c - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - dict lappend formattedchoices $groupname $cdisplay - } - } - } else { - set formattedchoices $choicegroups - #set formattedchoices [dict get $arginfo -choices] - } - } else { - if {[catch { - set trie [punk::trie::trieclass new {*}$allchoices_test] - set idents [dict get [$trie shortest_idents ""] scanned] - if {[dict get $arginfo -nocase]} { - #idents were calculated on lcase - remap keys in idents to original casing - set actual_idents $idents - foreach ch $allchoices_originalcase { - if {![dict exists $idents $ch]} { - #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting - #The actual testing is done in get_dict - dict set actual_idents $ch [dict get $idents [string tolower $ch]] - } - } - set idents $actual_idents - #puts "-----" - #puts "idents $idents" - } - - $trie destroy - dict for {groupname clist} $choicegroups { - foreach c $clist { - if {$c in $choiceprefixdenylist} { - set shortestid $c - } else { - set shortestid [dict get $idents $c] - } - if {$shortestid eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $shortestid] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]" - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - dict lappend formattedchoices $groupname $cdisplay - } - } - } errM]} { - #this failure can happen if -nocase is true and there are ambiguous entries - #e.g -nocase 1 -choices {x X} - puts stderr "prefix marking failed\n$errM" - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set cdisplay $c - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - dict lappend formattedchoices $groupname $cdisplay - } - } - } else { - set formattedchoices $choicegroups - } - - } - } - set choicetable_objects [list] - set choicetable_footers [dict create] - dict for {groupname formatted} $formattedchoices { - set numcols $choicecolumns ;#todo - dynamic? - if {[llength $formatted] < $numcols} { - #don't show blank cells if single line of results - set numcols [llength $formatted] - } - if {$numcols > 0} { - if {$use_table} { - #risk of recursing - #TODO -title directly in list_as_table - set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] - lappend choicetable_objects $choicetableobj - $choicetableobj configure -title $CLR(groupname)$groupname - #append help \n[textblock::join -- " " [$choicetableobj print]] - } else { - if {$groupname ne ""} { - append help \n \n "$CLR(groupname)Group: $groupname$RST" - } else { - append help \n - } - append help \n [join $formatted \n] - } - } else { - #we were given an empty set of choices. - #probably an error in the definition - but could happen if dynamically generated. - #(e.g ensemble where unknown mechanism is used for subcommands?) - #better to just display that there were none rather than totally break the usage output. - if {$usetable} { - #these will be displayed after all table entries - if {$groupname eq ""} { - dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" - } else { - dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" - } - } else { - if {$groupname eq ""} { - append help \n " " $CLR(errormsg)(no choices defined)$RST - } else { - append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST - } - } - } - } - set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width - foreach obj $choicetable_objects { - dict lappend twidths_by_colcount [$obj column_count] [$obj width] - } - foreach obj $choicetable_objects { - set cols [$obj column_count] - set widths [dict get $twidths_by_colcount $cols] - set max [tcl::mathfunc::max {*}$widths] - $obj configure -minwidth $max ;#expand smaller ones - set i 0 - while {$i < $cols} { - #keep text aligned left on expanded tables - $obj configure_column $i -blockalign left - incr i - } - - append help \n[textblock::join -- " " [$obj print]] - #set ansititle [dict get [$obj configure -title] value] - $obj destroy - } - if {[dict size $choicetable_footers]} { - foreach groupname [dict keys $formattedchoices] { - if {[dict exists $choicetable_footers $groupname]} { - append help \n [dict get $choicetable_footers $groupname] - } - } - } - - #review. use -type to restrict additional choices - may be different to values in the -choices - if {![dict get $arginfo -choicerestricted]} { - #when -choicemultiple - the -type refers to each selection - if {[dict get $arginfo -type] eq "string"} { - append help "\n (values not in defined choices are allowed)" - } else { - append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" - } - } - } - if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { - if {$is_multiple} { - set argshow "?${argshow}...?" - } else { - set argshow "?${argshow}?" - } - } else { - if {$is_multiple} { - set argshow "${argshow}..." - } - } - set typeshow [dict get $arginfo -type] - if {$typeshow eq "none"} { - set typeshow "$typeshow $soloflag" - } - if {[dict exists $arginfo -minsize]} { - append typeshow \n "-minsize [dict get $arginfo -minsize]" - } - if {[dict exists $arginfo -maxsize]} { - append typeshow \n "-maxsize [dict get $arginfo -maxsize]" - } - if {[dict exists $arginfo -range]} { - append typeshow \n "-range [dict get $arginfo -range]" - } - - if {$use_table} { - $t add_row [list $argshow $typeshow $default $multiple $help] - if {$arg eq $badarg} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG - } - } else { - #review - formatting will be all over the shop due to newlines in typesshow, help - set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" - foreach ln [split $help \n] { - append arghelp " $ln" \n - } - lappend errlines $arghelp - } - } - } - } ;#end is_custom_argdisplay - - if {$use_table} { - $t configure -show_hseps 0\ - -show_header 1\ - -ansibase_body $CLR(ansibase_body)\ - -ansibase_header $CLR(ansibase_header)\ - -ansiborder_header $CLR(ansiborder)\ - -ansiborder_body $CLR(ansiborder) - - $t configure -maxwidth 80 ;#review - if {$returntype ne "tableobject"} { - append errmsg [$t print] - #returntype of table means just the text of the table - $t destroy - } - } else { - append errmsg [join $errlines \n] - } - } errM]} { - catch {$t destroy} - append errmsg \n - append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n - append errmsg "$errM" \n - append errmsg "$::errorInfo" - - } - set arg_error_isrunning 0 - if {$use_table} { - #assert returntype is one of table, tableobject - set result $errmsg ;#default if for some reason table couldn't be used - if {$returntype eq "tableobject"} { - if {[info object isa object $t]} { - set result $t - } - } - } else { - set result $errmsg - } - if {$as_error} { - #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. - #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) - uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] - } else { - return $result - } - } - - - lappend PUNKARGS [list { - @dynamic - @id -id ::punk::args::usage - @cmd -name punk::args::usage -help\ - "Return usage information for a command identified by an id. - - This will only work for commands where a punk::args definition exists - for the command and an id has been defined for it. The id for custom - help for a command should match the fully qualified name of the command. - - Many commands (such as ensembles and oo objects) may have argument - documentation generated dynamically and may not yet have an id. - IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. - - Generally punk::ns::arginfo (aliased as i in the punk shell) should - be used in preference - as it will search for a documentation - mechanism and call punk::args::usage as necessary. - " - -return -default table -choices {string table tableobject} - } {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}} { - - @values -min 0 -max 1 - id -help\ - "Exact id. - Will usually match the command name" - }] - proc usage {args} { - lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received - set id [dict get $values id] - set real_id [real_id $id] - if {$real_id eq ""} { - error "punk::args::usage - no such id: $id" - } - arg_error "" [punk::args::get_spec $real_id] -scheme punk_info {*}$opts -aserror 0 - } - - lappend PUNKARGS [list { - @id -id ::punk::args::get_by_id - @cmd -name punk::args::get_by_id - @values -min 1 - id - arglist -type list -help\ - "list containing arguments to be parsed as per the - argument specification identified by the supplied id." - }] - - - #deprecate? - proc get_by_id {id arglist} { - set definitionlist [punk::args::raw_def $id] - if {[llength $definitionlist] == 0} { - error "punk::args::get_by_id - no such id: $id" - } - #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] - tailcall ::punk::args::get_dict {*}$definitionlist $arglist - } - - #consider - - #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) - #parse ?-flag val?... -- $arglist withid $id - #parse ?-flag val?... -- $arglist withdef $def ?$def?... - - #an experiment.. ideally we'd like arglist at the end? - #parse_withid ?-flag val?.. $id $arglist - #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? - #no possible equivalent for parse_withdef ??? - - lappend PUNKARGS [list { - @id -id ::punk::args::parse - @cmd -name punk::args::parse -help\ - "parse and validate command arguments based on a definition. - - In the 'withid' form the definition is a pre-existing record that has been - created with ::punk::args::define, or indirectly by adding a definition to - the PUNKARGS variable in a namespace which is then registered in - punk::args::register::NAMESPACES, or by a previous call to punk::parse - using 'withdef' and a definition block containing an @id -id directive. - - In the 'withdef' form - the definition is created on the first call and - cached thereafter, if the id didn't already exist. - - form1: parse $arglist ?-flag val?... withid $id - form2: parse $arglist ?-flag val?... withdef $def ?$def? - see punk::args::define - - Returns a dict of information regarding the parsed arguments - example of basic usage for single option only: - punk::args::define { - @id -id ::myns::myfunc - @cmd -name myns::myfunc - @leaders -min 0 -max 0 - @opts - -configfile -type existingfile - #type none makes it a solo flag - -verbose -type none - @values -min 0 -max 0 - } - proc myfunc {args} { - set argd [punk::args::parse $args withid ::myns::myfunc] - lassign [dict values $argd] leaders opts values received solos - if {[dict exists $received] -configfile} { - puts \"have option for existing file [dict get $opts -configfile]\" - } - } - The leaders, opts, values keys in the parse result dict are proper dicts. - The received key is dict-like but can have repeated keys for arguments than can - accept multiples. The value for each received element is the ordinal position. - The solos key refers to a list of solo flags received (those specified with - -type none). This is generally only useful to assist in passing arguments on - to another procedure which also requires solos, because the opts dict contains - solo flags with a 1 value or a list of 1's if it was a solo with -multiple true - specified. - " - @form -form {withid withdef} - @leaders -min 1 -max 1 - arglist -type list -optional 0 -help\ - "Arguments to parse - supplied as a single list" - - @opts - -form -type list -default * -help\ - "Restrict parsing to the set of forms listed. - Forms are the orthogonal sets of arguments a - command can take - usually described in 'synopsis' - entries." - #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance - #todo - configurable per interp/namespace - -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} - - @values -min 2 - - @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" - withid -type literal -help\ - "The literal value 'withid'" - id -type string -help\ - "id of punk::args definition for a command" - - - @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" - withdef -type literal -help\ - "The literal value 'withdef'" - - #todo - make -dynamic obsolete - use @dynamic directive instead - def -type string -multiple 1 -optional 0 -help\ - "Each remaining argument is a block of text - defining argument definitions. - As a special case, -dynamic may be - specified as the 1st 2 arguments. These are - treated as an indicator to punk::args about - how to process the definition." - - }] - proc parse {args} { - set tailtype "" ;#withid|withdef - if {[llength $args] < 3} { - error "punk::args::parse - invalid call. < 3 args" - } - set parseargs [lindex $args 0] - set tailargs [lrange $args 1 end] - - set split [lsearch -exact $tailargs withid] - if {$split < 0} { - set split [lsearch -exact $tailargs withdef] - if {$split < 0} { - #punk::args::usage arg_error? - error "punk::args::parse - invalid call. keyword withid|withdef required" - } else { - set tailtype withdef - } - } else { - set tailtype withid - } - - set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. - if {[llength $opts] % 2} { - error "punk::args::parse Even number of -flag val pairs required after arglist" - } - - #Default the -errorstyle to enhanced - # (slowest on unhappy path - but probably clearest for playing with new APIs interactively) - # - application devs should distribute a config file with an errorstyle override if desired. - # - devs who prefer a different default for interactive use should create a config for it. (todo) - set defaultopts [dict create\ - -form {*}\ - -errorstyle enhanced\ - ] - - #todo - load override_errorstyle from configuration - #dict set defaultopts -errorstyle $ - - set opts [dict merge $defaultopts $opts] - dict for {k v} $opts { - switch -- $k { - -form - -errorstyle { - } - default { - #punk::args::usage $args withid ::punk::args::parse ?? - error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" - } - } - } - switch -- $tailtype { - withid { - if {[llength [lrange $tailargs $split+1 end]] != 1} { - error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - } - set id [lindex $tailargs $split+1] - #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" - set deflist [raw_def $id] - if {[llength $deflist] == 0} { - error "punk::args::parse - no such id: $id" - } - } - withdef { - set deflist [lrange $tailargs $split+1 end] - if {[llength $deflist] < 1} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" - } - default { - error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" - } - } - try { - set result [punk::args::get_dict {*}$deflist $parseargs] - } trap {PUNKARGS VALIDATION} {msg erroropts} { - set opt_errorstyle [dict get $opts -errorstyle] - - #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - - - set ecode [dict get $erroropts -errorcode] - #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... - set msg [string map [list %caller% [Get_caller]] $msg] - switch -- $opt_errorstyle { - minimal { - return -options [list -code error -errorcode $ecode] $msg - } - basic { - #No table layout - unix manpage style - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg] - } - return -options [list -code error -errorcode $ecode] $msg - } - standard { - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg] - } - return -options [list -code error -errorcode $ecode] $msg - } - enhanced { - set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below) - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - set ecode_summary [lrange $ecode 0 2] - if {$badarg ne ""} { - lappend ecode_summary -badarg $badarg - } - catch {package require punk::lib} - if {[package provide punk::lib] ne ""} { - append msg \n [punk::lib::showdict -roottype list $estack */*] - } - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg] - append msg \n "::errorCode summary: $ecode_summary" - return -options [list -code error -errorcode $ecode] $msg - } else { - #why? todo? - append msg \n "(enhanced error information unavailable)" - append msg \n "::errorCode summary: $ecode_summary" - return -options [list -code error -errorcode $ecode] $msg - } - } - debug { - puts stderr "errorstyle debug not implemented" - return -options [list -code error -errorcode $ecode] $msg - } - } - } trap {PUNKARGS} {msg erropts} { - append msg \n "Unexpected PUNKARGS error" - return -options [list -code error -errorcode $ecode] $msg - } trap {} {msg erroropts} { - #review - #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. - #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. - throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] - } - return $result - } - proc parseXXX {args} { - #no solo flags allowed for parse function itself. (ok for arglist being parsed) - set opts [dict create] ;#repeated flags will override earlier. That's ok here. - set arglist {} - set got_arglist 0 - set tailtype "" ;#withid|withdef - set id "" - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {[string match -* $a]} { - dict set opts $a [lindex $args $i+1] - incr i - } else { - set arglist $a - set got_arglist 1 - set tailtype [lindex $args $i+1] - if {$tailtype eq "withid"} { - if {[llength $args] != $i+3} { - error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - } - set id [lindex $args $i+2] - break - } elseif {$tailtype eq "withdef"} { - if {[llength $args] < $i+3} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - set deflist [lrange $args $i+2 end] - break - } else { - error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" - } - } - } - if {!$got_arglist} { - error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." - } - #assert tailtype eq withid|withdef - if {$tailtype eq "withid"} { - #assert $id was provided - return "parse [llength $arglist] args withid $id, options:$opts" - } else { - #assert llength deflist >=1 - return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" - } - #TODO - } - - #todo? - a version of get_dict that directly supports punk::lib::tstr templating - #rename get_dict - # - - #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 get_dict {args} { - #see arg_error regarding considerations around unhappy-path performance - - #consider a better API - # - e.g punk::args::parse ?-flag val?... $arglist withid $id - # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? - #can the above be made completely unambiguous for arbitrary arglist?? - #e.g what if arglist = withdef and the first $def is also withdef ? - - - #*** !doctools - #[call [fun get_dict] [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 values - #[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 defining a flag 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 - #[para]Each optionspec line defining a positional argument is of the form: - #[para]argumentname -key val -ky2 val2... - #[para]where the valid keys for each option specification are: -default -type -range -choices - #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value - #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. - #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. - #[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, - #but it could be a manually constructed list of values made for example from positional args defined in the proc. - #[list_end] - #[para] - - #consider line-processing example below for which we need info complete to determine record boundaries - #punk::args::get_dict { - # @opts - # -opt1 -default {} - # -opt2 -default { - # etc - # } - # @values -multiple 1 - #} $args - - set rawargs [lindex $args end] ;# args values to be parsed - #we take a definition list rather than argspecs - because the definition could be dynamic - set definition_args [lrange $args 0 end-1] - - #if definition has been seen before, - #define will either return a permanently cached argspecs (-dynamic 0) - or - # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. - set argspecs [uplevel 1 [list ::punk::args::resolve {*}$definition_args]] - - # ----------------------------------------------- - # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) - tcl::dict::with argspecs {} ;#turn keys into vars - # TODO - capitalise 'define' vars to make it a bit easier - # ----------------------------------------------- - - #puts "-arg_info->$arg_info" - set flagsreceived [list] ;#for checking if required flags satisfied - set solosreceived [list] - #secondary purpose: - #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 ? - - # -- --- --- --- - # Handle leading positionals - # todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ? - set opts $opt_defaults - set pre_values {} - - set argnames [tcl::dict::keys $ARG_INFO] - set optnames [lsearch -all -inline $argnames -*] - set ridx 0 - set rawargs_copy $rawargs - set leader_posn_name "" - set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) - set is_multiple 0 ;#last leader may be multi - if {$LEADER_MAX != 0} { - foreach r $rawargs_copy { - if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { - break - } - if {$ridx == [llength $LEADER_NAMES]-1} { - #at last named leader - set leader_posn_name [lindex $LEADER_NAMES $ridx] - if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { - set is_multiple 1 - } - } elseif {$ridx > [llength $LEADER_NAMES]-1} { - #beyond names - retain name if -multiple was true - if {!$is_multiple} { - set leader_posn_name "" - } - } else { - set leader_posn_name [lindex $LEADER_NAMES $ridx] ;#may return empty string - } - if {$r eq "--"} { - #review end of opts marker: '--' can't be a leader (but can be a value) - break - } - - #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option - if {[tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { - set matchopt [::tcl::prefix::match -error {} $optnames $r] - if {$matchopt ne ""} { - #flaglike matches a known flag - don't treat as leader - break - } - #if {![string match -* [lindex $argnames $ridx]]} {} - if {$leader_posn_name ne ""} { - #there is a named leading positional for this position - #The flaglooking value doesn't match an option - so treat as a leader - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - incr ridx - continue - } else { - break - } - } - - #for each branch - break or lappend - if {$leader_posn_name ne ""} { - if {$leader_posn_name ni $LEADER_REQUIRED} { - #optional leader - - #most adhoc arg processing will allocate based on number of args rather than matching choice values first - #(because a choice value could be a legitimate data value) - - #review - option to process in this manner? - #first check if the optional leader value is a match for a choice ? - #if {[dict exists $arg_info $leader_posn_name -choices]} { - # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] [lindex $rawargs 0]] - # if {$vmatch ne ""} { - # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values - # lappend pre_values [lpop rawargs 0] - # incr ridx - # continue - # } - #} - - #check if enough rawargs to fill any required values - if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { - break - } else { - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #required - if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { - #already accepted at least one value - requirement satisfied - now equivalent to optional - if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { - break - } - } - #if we didn't break - requirement is not yet satisfied, or is satisfied but stil enough rawargs for required values - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #unnamed leader - if {$LEADER_MIN ne "" } { - if {$ridx > $LEADER_MIN} { - break - } else { - #haven't reached LEADER_MIN - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - break - } - } - - incr ridx - } ;# end foreach r $rawargs_copy - } - - set argstate $ARG_INFO ;#argstate may have entries added - set arg_checks $ARG_CHECKS - - if {$LEADER_MIN eq ""} { - set leadermin 0 - } else { - set leadermin $LEADER_MIN - } - if {$LEADER_MAX eq ""} { - set leadermax -1 - } else { - set leadermax $LEADER_MAX - } - - #assert leadermax leadermin are numeric - #assert - rawargs has been reduced by leading positionals - - set leaders [list] - set arglist {} - set post_values {} - #val_min, val_max - #puts stderr "rawargs: $rawargs" - #puts stderr "argstate: $argstate" - if {[lsearch $rawargs -*] >= 0} { - #at least contains flaglike things.. - set maxidx [expr {[llength $rawargs] -1}] - if {$val_max == -1} { - set vals_total_possible [llength $rawargs] - set vals_remaining_possible $vals_total_possible - } else { - set vals_total_possible $val_max - set vals_remaining_possible $vals_total_possible - } - for {set i 0} {$i <= $maxidx} {incr i} { - set a [lindex $rawargs $i] - set remaining_args_including_this [expr {[llength $rawargs] - $i}] - #lowest val_min is 0 - if {$remaining_args_including_this <= $val_min} { - # if current arg is -- it will pass through as a value here - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - - #exlude argument with whitespace from being a possible option e.g dict - if {[tcl::string::match -* $a] && !([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { - if {$a eq "--"} { - #remaining num args <= val_min already covered above - if {$val_max != -1} { - #finite max number of vals - if {$remaining_args_including_this == $val_max} { - #assume it's a value. - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - } else { - #assume it's an end-of-options marker - lappend flagsreceived -- - set arglist [lrange $rawargs 0 $i] - set post_values [lrange $rawargs $i+1 end] - } - } else { - #unlimited number of post_values accepted - #treat this as eopts - we don't care if remainder look like options or not - lappend flagsreceived -- - set arglist [lrange $rawargs 0 $i] - set post_values [lrange $rawargs $i+1 end] - } - break - } else { - set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] - if {$fullopt ne ""} { - if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { - #non-solo - #check if it was actually a value that looked like a flag - if {$i == $maxidx} { - #if no optvalue following - assume it's a value - #(caller should probably have used -- before it) - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - - set flagval [lindex $rawargs $i+1] - if {[tcl::dict::get $argstate $fullopt -multiple]} { - #don't lappend to default - we need to replace if there is a default - if {$fullopt ni $flagsreceived} { - tcl::dict::set opts $fullopt [list $flagval] - } else { - tcl::dict::lappend opts $fullopt $flagval - } - } else { - tcl::dict::set opts $fullopt $flagval - } - #incr i to skip flagval - incr vals_remaining_possible -2 - if {[incr i] > $maxidx} { - set msg "Bad options for %caller%. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $fullopt index [expr {$i-1}]] -badarg $fullopt -argspecs $argspecs]] $msg - #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $fullopt - } - } else { - #solo - if {[tcl::dict::get $argstate $fullopt -multiple]} { - if {$fullopt ni $flagsreceived} { - #override any default - don't lappend to it - tcl::dict::set opts $fullopt 1 - } else { - tcl::dict::lappend opts $fullopt 1 - } - } else { - tcl::dict::set opts $fullopt 1 - } - incr vals_remaining_possible -1 - lappend solosreceived $fullopt ;#dups ok - } - lappend flagsreceived $fullopt ;#dups ok - } else { - #unmatched option flag - #comparison to val_min already done above - if {$val_max ne -1 && $remaining_args_including_this <= $val_max} { - #todo - look at optspec_default and see if solo/vs opt-val pair - #we may need to lookahead by 2 regarding val_max val_min - - #even with optany - assume an unknown within the space of possible values is a value - #unmatched option in right position to be considered a value - treat like eopts - #review - document that an unspecified arg within range of possible values will act like eopts -- - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - if {$opt_any} { - set newval [lindex $rawargs $i+1] - #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option - tcl::dict::set argstate $a $optspec_defaults ;#use default settings for unspecified opt - tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS - if {[tcl::dict::get $argstate $a -type] ne "none"} { - if {[tcl::dict::get $argstate $a -multiple]} { - tcl::dict::lappend opts $a $newval - } else { - tcl::dict::set opts $a $newval - } - if {[incr i] > $maxidx} { - set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg - #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a - } - incr vals_remaining_possible -2 - } else { - #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none - if {[tcl::dict::get $argstate $a -multiple]} { - if {![tcl::dict::exists $opts $a]} { - tcl::dict::set opts $a 1 - } else { - tcl::dict::lappend opts $a 1 - } - } else { - tcl::dict::set opts $a 1 - } - incr vals_remaining_possible -1 - lappend solosreceived $a - } - lappend flagsreceived $a ;#adhoc flag as supplied - } else { - if {[llength $OPT_NAMES]} { - set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" - } else { - set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" - } - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg - #arg_error $errmsg $argspecs -badarg $fullopt - } - } - } - } else { - #not flaglike - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - } - #set values [list {*}$pre_values {*}$post_values] - set leaders $pre_values - set values $post_values - } else { - set leaders $pre_values - set values $rawargs - #set values [list {*}$pre_values {*}$rawargs] ;#no -flags detected - set arglist [list] - } - #puts stderr "--> arglist: $arglist" - #puts stderr "--> values: $values" - - - set positionalidx 0 ;#index for unnamed positionals (both leaders and values) - set ldridx 0 - set in_multiple "" - set leadernames_received [list] - set leaders_dict $LEADER_DEFAULTS - set num_leaders [llength $leaders] - foreach leadername $LEADER_NAMES ldr $leaders { - if {$ldridx+1 > $num_leaders} { - break - } - if {$leadername ne ""} { - if {[tcl::dict::get $argstate $leadername -multiple]} { - if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { - tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list - } else { - tcl::dict::lappend leaders_dict $leadername $ldr - } - set in_multiple $leadername - } else { - tcl::dict::set leaders_dict $leadername $ldr - } - lappend leadernames_received $leadername - } else { - if {$in_multiple ne ""} { - tcl::dict::lappend leaders_dict $in_multiple $ldr - lappend leadernames_received $in_multiple ;#deliberately allow dups! (as with opts and values) - } else { - tcl::dict::set leaders_dict $positionalidx $ldr - tcl::dict::set argstate $positionalidx $leaderspec_defaults - tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS - lappend leadernames_received $positionalidx - } - } - incr ldridx - incr positionalidx - } - - set validx 0 - set in_multiple "" - set valnames_received [list] - set values_dict $val_defaults - set num_values [llength $values] - foreach valname $VAL_NAMES val $values { - if {$validx+1 > $num_values} { - break - } - if {$valname ne ""} { - if {[tcl::dict::get $argstate $valname -multiple]} { - if {[tcl::dict::exists $val_defaults $valname]} { - #current stored val equals defined default - don't include default in the list we build up - tcl::dict::set values_dict $valname [list $val] ;#important to treat first element as a list - } else { - tcl::dict::lappend values_dict $valname $val - } - set in_multiple $valname - } else { - tcl::dict::set values_dict $valname $val - } - lappend valnames_received $valname - } else { - if {$in_multiple ne ""} { - tcl::dict::lappend values_dict $in_multiple $val - #name already seen - but must add to valnames_received anyway (as with opts and leaders) - lappend valnames_received $in_multiple - } else { - tcl::dict::set values_dict $positionalidx $val - tcl::dict::set argstate $positionalidx $valspec_defaults - tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS - lappend valnames_received $positionalidx - } - } - incr validx - incr positionalidx - } - - if {$leadermax == -1} { - #only check min - if {$num_leaders < $leadermin} { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected at least $leadermin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leadermin" $argspecs - } - } else { - if {$num_leaders < $leadermin || $num_leaders > $leadermax} { - if {$leadermin == $leadermax} { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected exactly $leadermin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leadermin" $argspecs - } else { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" $argspecs - } - } - } - - if {$val_max == -1} { - #only check min - if {$num_values < $val_min} { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $val_min" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg - #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected at least $val_min" $argspecs - } - } else { - if {$num_values < $val_min || $num_values > $val_max} { - if {$val_min == $val_max} { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $val_min" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg - #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected exactly $val_min" $argspecs - } else { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $val_min and $val_max inclusive" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg - #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected between $val_min and $val_max inclusive" $argspecs - } - } - } - - #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options - - - #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 SHOULD? 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 - - #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? - #example timing difference: - #struct::set difference {x} {a b} - #normal interp 0.18 u2 vs safe interp 9.4us - #if {[llength [set missing [struct::set difference $opt_required $flagsreceived]]]} { - # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" - #} - #if {[llength [set missing [struct::set difference $val_required $valnames_received]]]} { - # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" - #} - #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us - if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { - set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadermissing $missing received $leadernames_received] -argspecs $argspecs]] $msg - #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - if {[llength [set missing [punklib_ldiff $opt_required $flagsreceived]]]} { - set msg "Required option missing for %caller%. missing flags: '$missing' are marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list optionmissing $missing received $flagsreceived] -argspecs $argspecs]] $msg - #arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs - } - if {[llength [set missing [punklib_ldiff $val_required $valnames_received]]]} { - set msg "Required value missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list valuemissing $missing received $valnames_received] -argspecs $argspecs]] $msg - #arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - - - #todo - truncate/summarize values in error messages - - #todo - allow defaults outside of choices/ranges - - #check types,ranges,choices - set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] - #set combined_defaults [tcl::dict::merge $val_defaults $opt_defaults] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash - #puts "---opts_and_values:$opts_and_values" - #puts "---argstate:$argstate" - tcl::dict::for {argname v} $opts_and_values { - set thisarg [tcl::dict::get $argstate $argname] - #set thisarg_keys [tcl::dict::keys $thisarg] - set thisarg_checks [tcl::dict::get $arg_checks $argname] - set is_multiple [tcl::dict::get $thisarg -multiple] - set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] - set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] - set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] - set has_default [tcl::dict::exists $thisarg -default] - if {$has_default} { - set defaultval [tcl::dict::get $thisarg -default] - } - set type [tcl::dict::get $thisarg -type] - set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] - set regexprepass [tcl::dict::get $thisarg -regexprepass] - set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 - set validationtransform [tcl::dict::get $thisarg -validationtransform] - - - if {$is_multiple} { - set vlist $v - } else { - set vlist [list $v] - } - set vlist_original $vlist ;#retain for possible final strip_ansi - - #review - validationtransform - if {$is_validate_ansistripped} { - #validate_ansistripped 1 - package require punk::ansi - set vlist_check [list] - foreach e $vlist { - lappend vlist_check [punk::ansi::ansistrip $e] - } - } else { - #validate_ansistripped 0 - set vlist_check $vlist - } - - #reduce our validation requirements by removing values which match defaultval or match -choices - #(could be -multiple with -choicerestriction 0 where some selections match and others don't) - if {$has_choices} { - #-choices must also work with -multiple - #todo -choicelabels - set choiceprefix [tcl::dict::get $thisarg -choiceprefix] - set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] - set choicerestricted [tcl::dict::get $thisarg -choicerestricted] - set choicemultiple [tcl::dict::get $thisarg -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set nocase [tcl::dict::get $thisarg -nocase] - set choices [Dict_getdef $thisarg -choices {}] - set choicegroups [Dict_getdef $thisarg -choicegroups {}] - set allchoices $choices - if {[dict size $choicegroups]} { - dict for {groupname groupmembers} $choicegroups { - lappend allchoices {*}$groupmembers - } - } - #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups - #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes - - - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - set dname leaders_dict - } - option { - set dname opts - } - value { - set dname values_dict - } - } - set idx 0 ;# - #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes - #assert llength $vlist == llength [dict get $dname $argname] - # (unless there was a default and the option wasn't specified) - set vlist_validate [list] - set vlist_check_validate [list] - foreach e $vlist e_check $vlist_check { - set allchoices_in_list 0 - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - #vlist and vlist_check can be list of lists if -multiple and -choicemultiple - #each e represents 0 or more choice selections - set c_list $e - set c_check_list $e_check - #todo? check if entire list matches default? - } else { - #only one choice at a time - ensure single entry in c_list c_check_list - set c_list [list $e] - set c_check_list [list $e_check] - } - - - #----------------------------------- - #fast fail on the wrong number of choices - if {[llength $c_list] < $choicemultiple_min} { - set msg "Option $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { - set msg "Option $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - #----------------------------------- - - set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list - foreach c $c_list c_check $c_check_list { - if {$nocase} { - set casemsg " (case insensitive)" - set choices_test [tcl::string::tolower $allchoices] - #Don't lcase the denylist - even in nocase mode! - #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] - set v_test [tcl::string::tolower $c_check] - } else { - set casemsg " (case sensitive)" - set v_test $c_check - set choices_test $allchoices - } - set choice_in_list 0 - set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? - if {!$matches_default} { - if {$choiceprefix} { - #can we handle empty string as a choice? It should just work - REVIEW/test - set choice_exact_match 0 - if {$c_check in $allchoices} { - #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing - set chosen $c_check - set choice_in_list 1 - set choice_exact_match 1 - } elseif {$v_test in $choices_test} { - #assert - if we're here, nocase must be true - #we know choice is present as full-length match except for case - #now we want to select the case from the choice list - not the supplied value - #we don't set choice_exact_match - because we will need to override the optimistic existing val below - #review - foreach avail [lsort -unique $allchoices] { - if {[string match -nocase $c $avail]} { - set chosen $avail - } - } - #assert chosen will always get set - set choice_in_list 1 - } else { - #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. - #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. - #in this block we can treat empty result from prefix match as a non-match - if {$nocase} { - #nocase implies that our entered value doesn't have to match case of choices - - #but we would still like to select the best match if there are case-dups. - #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete - # selecting Del will find Delete, del will match delete (and raise error) - # but DEL will also match delete rather than Delete - so again an error is raised. - #This is counterintuitive with -nocase - #This is probably such an edge case that best served with documentation as a feature-not-bug - #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? - #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. - - set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] - if {$bestmatch eq ""} { - set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] - #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing - set chosen [lsearch -inline -nocase $allchoices $chosen] - set choice_in_list [expr {$chosen ne ""}] - } else { - set chosen $bestmatch - set choice_in_list 1 - } - } else { - set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] - if {$chosen eq ""} { - set choice_in_list 0 - } else { - set choice_in_list 1 - } - } - #override choice_in_list if in deny list - #don't allow prefixing for elements from -choiceprefixdenylist - #we still use all elements to calculate the prefixes though - #review - case difference edge cases in choiceprefixdenylist !todo - if {$chosen in $choiceprefixdenylist} { - set choice_in_list 0 - set chosen "" - } - } - - #override the optimistic existing val - if {$choice_in_list && !$choice_exact_match} { - if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { - if {$is_multiple} { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $idx $chosen - tcl::dict::set $dname $argname $existing - } else { - tcl::dict::set $dname $argname $chosen - } - } else { - if {$is_multiple} { - set existing_all [tcl::dict::get [set $dname] $argname] - lset existing_all $idx $choice_idx $chosen - tcl::dict::set $dname $argname $existing_all - } else { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $choice_idx $chosen - tcl::dict::set $dname $argname $existing - } - } - } - } else { - #value as stored in $dname is ok - set choice_in_list [expr {$v_test in $choices_test}] - } - } - - if {!$choice_in_list && !$matches_default} { - if {!$choicerestricted} { - #if {$is_multiple} { - # set existing [tcl::dict::get [set $dname] $argname] - # lset existing $idx $v_test - # tcl::dict::set $dname $argname $existing - #} else { - # tcl::dict::set $dname $argname $v_test - #} - lappend vlist_validate $c - lappend vlist_check_validate $c_check - } else { - #unhappy path - if {$choiceprefix} { - set prefixmsg " (or a unique prefix of a value)" - } else { - set prefixmsg "" - } - #review: $c vs $c_check for -badval? - set msg "Option '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname - } - } - incr choice_idx - } - - incr idx - } - #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation - #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - - if {[llength $vlist] && $has_default} { - set vlist_validate [list] - set vlist_check_validate [list] - foreach c $vlist c_check $vlist_check { - #for -choicemultiple with default that could be a list use 'ni' ?? review - if {$c_check ne $defaultval} { - lappend vlist_validate $c - lappend vlist_check_validate $c - } - } - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - - #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups - #assert: our vlist & vlist_check lists have been reduced to remove those - if {[llength $vlist] && !$is_allow_ansi} { - #allow_ansi 0 - package require punk::ansi - #do not run ta::detect on a list - foreach e $vlist { - if {[punk::ansi::ta::detect $e]} { - set msg "Option '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg - #error "Option $argname for [Get_caller] contains ansi - but -allow_ansi is false. Received: '$e'" - } - } - } - #puts "argname:$argname v:$v is_default:$is_default" - #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. - #arguments that are at their default are not subject to type and other checks - - #don't validate defaults or choices that matched - #puts "---> opts_and_values: $opts_and_values" - #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" - #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} - - #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups - #assert [llength $vlist] == [llength $vlist_check] - if {[llength $vlist]} { - switch -- $type { - any {} - list { - foreach e_check $vlist_check { - if {![tcl::string::is list -strict $e_check]} { - set msg "Option '$argname' for %caller% requires type 'list'. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires type 'list'. Received: '$e_check'" $argspecs -badarg $argname - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[llength $e_check] < $checkval} { - set msg "Option '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e -badval $e_check -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires list with -minsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[llength $e_check] > $checkval} { - set msg "Option '$argname for %caller% requires list with -maxsize $checkval. Received len:[llength $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $e -badval $e_check -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires list with -maxsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - } - } - } - } - } - } - string - ansistring - globstring { - #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string - #we possibly don't want to always have to regex on things that don't pass the other more basic checks - # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) - # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) - # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead - # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function - # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) - # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail - - #todo? - way to validate both unstripped and stripped? - set pass_quick_list_e [list] - set pass_quick_list_e_check [list] - set remaining_e $vlist - set remaining_e_check $vlist_check - #review - order of -regexprepass and -regexprefail in original rawargs significant? - #for now -regexprepass always takes precedence - if {$regexprepass ne ""} { - foreach e $vlist e_check $vlist_check { - if {[regexp $regexprepass $e]} { - lappend pass_quick_list_e $e - lappend pass_quick_list_e_check $e_check - } - } - set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] - set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] - } - if {$regexprefail ne ""} { - foreach e $remaining_e e_check $remaining_e_check { - #puts "----> checking $e vs regex $regexprefail" - if {[regexp $regexprefail $e]} { - if {[tcl::dict::exists $thisarg -regexprefailmsg]} { - #review - %caller% ?? - set msg [tcl::dict::get $thisarg -regexprefailmsg] - } else { - set msg "Option $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" - } - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $e -argspecs $argspecs]] $msg - #arg_error $msg $argspecs -badarg $argname - } - } - } - switch -- $type { - ansistring { - #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi - #.. so we need to look at the original values in $vlist not $vlist_check - - #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? - #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? - package require punk::ansi - foreach e $remaining_e { - if {![punk::ansi::ta::detect $e]} { - set msg "Option '$argname' for %caller% requires ansistring - but no ansi detected" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires ansistring - but no ansi detected" $argspecs -badarg $argname - } - } - } - globstring { - foreach e $remaining_e { - if {![regexp {[*?\[\]]} $e]} { - set msg "Option '$argname' for %caller% requires globstring - but no glob characters detected" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires globstring - but no glob characters detected" $argspecs -badarg $argname - } - } - } - } - - if {[tcl::dict::size $thisarg_checks]} { - foreach e_check $remaining_e_check { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[tcl::string::length $e_check] < $checkval} { - set msg "Option '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::string::length $e_check] > $checkval} { - set msg "Option '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - } - } - } - } - } - } - int { - #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive - if {[tcl::dict::exists $thisarg -range]} { - lassign [tcl::dict::get $thisarg -range] low high - if {"$low$high" ne ""} { - if {$low eq ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error "Option '$argname' for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname - } - #lowside unspecified - check only high - if {$e_check > $high} { - set msg "Option '$argname' for %caller% must be integer greater than or equal to $hight. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error "Option '$argname' for [Get_caller] must be integer less than or equal to $high. Received: '$e'" $argspecs -badarg $argname - } - } - } elseif {$high eq ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname - } - #highside unspecified - check only low - if {$e_check < $low} { - set msg "Option '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs -badarg $argname - } - } - } else { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname - } - #high and low specified - if {$e_check < $low || $e_check > $high} { - set msg "Option '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs -badarg $argname - } - } - } - } - } else { - foreach e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "Option $argname for %caller% requires type integer. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e_check'" $argspecs -badarg $argname - } - } - } - } - double { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is double -strict $e_check]} { - set msg "Option $argname for %caller% requires type double. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - #error "Option $argname for [Get_caller] requires type 'double'. Received: '$e'" - } - if {[tcl::dict::size $thisarg_checks]} { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -range { - #todo - small-value double comparisons with error-margin? review - #todo - empty string for low or high - lassign $checkval low high - if {$e_check < $low || $e_check > $high} { - set msg "Option $argname for %caller% must be double between $low and $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] must be between $low and $high. Received: '$e'" $argspecs -badarg $argname - } - } - } - } - } - } - } - bool { - foreach e_check $vlist_check { - if {![tcl::string::is boolean -strict $e_check]} { - set msg "Option $argname for %caller% requires type boolean. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires type 'boolean'. Received: '$e_check'" $argspecs -badarg $argname - } - } - } - dict { - foreach e_check $vlist_check { - if {[llength $e_check] %2 != 0} { - set msg "Option '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires type 'dict' - must be key value pairs. Received: '$e_check'" $argspecs -badarg $argname - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[tcl::dict::size $e_check] < $checkval} { - set msg "Option '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires dict with -minsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::dict::size $e_check] > $checkval} { - set msg "Option '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires dict with -maxsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - } - } - } - } - } - } - alnum - - alpha - - ascii - - control - - digit - - graph - - lower - - print - - punct - - space - - upper - - wordchar - - xdigit { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is $type $e_check]} { - #set msg "Option $argname for [Get_caller] requires type '$type'. Received: '$e'" - #try trap? - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type]]] $result - #throw ? - set msg "Option $argname for %caller% requires type '$type'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error $msg $argspecs -badarg $argname - } - } - } - file - - directory - - existingfile - - existingdirectory { - foreach e $vlist e_check $vlist_check { - #//review - we may need '?' char on windows - if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { - #what about special file names e.g on windows NUL ? - set msg "Option $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" $argspecs -badarg $argname - } - } - if {$type eq "existingfile"} { - foreach e $vlist e_check $vlist_check { - if {![file exists $e_check]} { - set msg "Option $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing file" $argspecs -badarg $argname - } - } - } elseif {$type eq "existingdirectory"} { - foreach e $vlist e_check $vlist_check { - if {![file isdirectory $e_check]} { - set msg "Option $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing directory" $argspecs -badarg $argname - } - } - } - } - char { - #review - char vs unicode codepoint vs grapheme? - foreach e $vlist e_check $vlist_check { - if {[tcl::string::length $e_check] != 1} { - set msg "Option $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires type 'character'. Received: '$e' which is not a single character" $argspecs -badarg $argname - } - } - } - } - - } - - if {$is_strip_ansi} { - set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach - if {[tcl::dict::get $thisarg -multiple]} { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict $argname $stripped_list - } - option { - tcl::dict::set opts $argname $stripped_list - } - value { - tcl::dict::set values_dict $argname $stripped_list - } - } - } else { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict [lindex $stripped_list 0] - } - option { - tcl::dict::set opts $argname [lindex $stripped_list 0] - } - value { - tcl::dict::set values_dict [lindex $stripped_list 0] - } - } - } - } - } - - #maintain order of opts $opts values $values as caller may use lassign. - set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] - if {[llength $receivednames]} { - #flat zip of names with overall posn, including opts - #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] - set i -1 - set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] - } else { - set received_posns [list] - } - #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) - #(e.g using 'dict exists $received -flag') - # - but it can have duplicate keys when args/opts have -multiple 1 - #It is actually a list of paired elements - return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived] - } - - #proc sample1 {p1 args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [opt {?option value...?}]] - # #[para]Description of sample1 - # return "ok" - #} - - - lappend PUNKARGS [list { - @id -id ::punk::args::TEST - @opts -optional 0 - -o1 -default 111 -help "opt 1 mandatory" - @opts -optional 1 - -o2 -default 222 -help "opt 2 optional" - @values -min 0 -max 1 - v -help\ - "v1 optional" - }] - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::lib { - variable PUNKARGS - tcl::namespace::export * - tcl::namespace::path [list [tcl::namespace::parent]] - #*** !doctools - #[subsection {Namespace punk::args::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 flatzip {l1 l2} { - concat {*}[lmap a $l1 b $l2 {list $a $b}] - } - - if {[info commands lseq] ne ""} { - #tcl 8.7+ lseq significantly faster, especially for larger ranges - #The internal rep can be an 'arithseries' with no string representation - proc zero_based_posns {count} { - if {$count < 1} {return} - lseq 0 $count-1 - } - } else { - proc zero_based_posns {count} { - if {$count < 1} {return} - lsearch -all [lrepeat $count 0] * - } - } - - - #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 -1] in calling scope ${[lindex [set x] 0]} !} - lappend PUNKARGS [list { - @id -id ::punk::args::lib::tstr - @cmd -name punk::args::lib::tstr -help\ - "A rough equivalent of js template literals - - Substitutions: - \$\{$varName\} - \$\{[myCommand]\} - (when -allowcommands flag is given)" - -allowcommands -default 0 -type none -help\ - "If -allowcommands is present, placeholder can contain commands - e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" - -undent -default 1 -type boolean -help\ - "undent/dedent the template lines. - The longest common prefix of whitespace is removed" - -indent -default "" -type string -help\ - "String with which to indent the template - prior to substitution. - If -undent is enabled, that is performed - first, then the indent is applied." - -paramindents -default line -choices {none line position} -choicelabels { - line\ - " Use leading whitespace in - the line in which the - placeholder occurs." - position\ - " Use the position in - the line in which the - placeholder occurs." - none\ - " No indents applied to - subsequent placeholder value - lines. This will usually - result in text awkwardly - ragged unless the source code - has also been aligned with the - left margin or the value has - been manually padded." - } -help\ - "How indenting is done for subsequent lines in a - multi-line placeholder substitution value. - The 1st line or a single line value is always - placed at the placeholder. - paramindents are performed after the main - template has been indented/undented. - (indenting by position does not calculate - unicode double-wide or grapheme cluster widths) - " - #choicelabels indented by 1 char is clearer for -return string - and reasonable in table - -return -default string -choices {dict list string args}\ - -choicelabels { - dict\ - " Return a dict with keys - 'template', 'params' and - 'errors'" - string\ - " Return a single result - being the string with - placeholders substituted." - list\ - " Return a 2 element list. - The first is itself a list - of plaintext portions of the - template, split at each point - at which placeholders were - present. The second element - of the outer list is a list - of placeholder values if -eval - is 1, or a list of the raw - placeholder strings if -eval - is 0." - args\ - " Return a list where the first - element is a list of template - plaintext sections as per the - 'list' return mechanism, but the - placeholder items are individual - items in the returned list. - This can be useful when passing - the expanded result of a tstr - command to another function - which expects the placeholders - as individual arguments" - } - -eval -default 1 -type boolean -help\ - "Whether to evaluate the \$\{\} placeholders. - When -return is string, -eval should generally be set to 1. - For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. - contained variables in that case should be braced or whitespace separated, or the variable - name is likely to collide with surrounding text. - e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" - @values -min 0 -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 - e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} - - Escape sequences such as \\n and unicode escapes are processed within placeholders. - " - }] - - proc tstr {args} { - #Too hard to fully eat-our-own-dogfood from within punk::args package - # - we use punk::args within the unhappy path only - #set argd [punk::args::get_by_id ::punk::lib::tstr $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 opt_eval [dict get $argd opts -eval] - - set templatestring [lindex $args end] - set arglist [lrange $args 0 end-1] - set opts [dict create\ - -allowcommands 0\ - -undent 1\ - -indent ""\ - -paramindents line\ - -eval 1\ - -return string\ - ] - if {"-allowcommands" in $arglist} { - set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] - dict set opts -allowcommands 1 - } - if {[llength $arglist] % 2 != 0} { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr expected option/value pairs prior to last argument" - } - } - dict for {k v} $arglist { - set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] - switch -- $fullk { - -indent - -undent - -paramindents - -return - -eval { - dict set opts $fullk $v - } - default { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" - } - } - } - } - set opt_allowcommands [dict get $opts -allowcommands] - set opt_paramindents [dict get $opts -paramindents] - set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] - if {$test_paramindents ni {none line position}} { - error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." - } - set opt_paramindents $test_paramindents - set opt_return [dict get $opts -return] - set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] - if {$opt_return eq ""} { - } - set opt_eval [dict get $opts -eval] - - - set nocommands "-nocommands" - if {$opt_allowcommands == 1} { - set nocommands "" - } - - set opt_undent [dict get $opts -undent] - if {$opt_undent} { - set templatestring [punk::args::lib::undent $templatestring] - } - set opt_indent [dict get $opts -indent] - if {$opt_indent ne ""} { - set templatestring [punk::args::lib::indent $templatestring $opt_indent] - } - - #set parts [_tstr_split $templatestring] - if {[string first \$\{ $templatestring] < 0} { - set parts [list $templatestring] - } else { - set parts [_parse_tstr_parts $templatestring] - } - set textchunks [list] - #set expressions [list] - set params [list] - set idx 0 - set errors [dict create] - set lastline "" ;#todo - first line has placeholder? - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach {pt expression} $parts { - lappend textchunks $pt - incr idx ;#pt incr - - #ignore last expression - if {$idx == [llength $parts]} { - break - } - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - #lappend expressions $expression - #---------------------- - #REVIEW - JMN - #TODO - debug punk::args loading of @dynamic defs - #puts "-- $expression" - #---------------------- - #brk1 - literal newline not {\n} - set leader "" - if {[set brk1 [string first \n $expression]] >= 0} { - #undent left of paramstart only for lines of expression that arent on opening ${..} line - set tail [string range $expression $brk1+1 end] - set leader [string repeat " " [string length $lastline]] - set undentedtail [punk::args::lib::undentleader $tail $leader] - #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] - set expression "[string range $expression 0 $brk1]$undentedtail" - } - if {$opt_eval} { - if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { - lappend params [string cat \$\{ $expression \}] - dict set errors [expr {[llength $params]-1}] $result - } else { - set result [string map [list \n "\n$leader"] $result] - lappend params $result - } - #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] - } else { - lappend params [subst -nocommands -novariables $expression] - } - append lastline [lindex $params end] ;#for current expression's position calc - - incr idx ;#expression incr - } - - if {$opt_return eq "dict"} { - return [dict create template $textchunks params $params errors $errors] - } - if {[dict size $errors]} { - set einfo "" - dict for {i e} $errors { - append einfo "parameter $i error: $e" \n - } - #REVIEW!!! - #TODO - fix - #puts stderr "tstr errors:\n$einfo\n" - } - - switch -- $opt_return { - list { - return [list $textchunks $params] - } - args { - #see example in tstr_test_one - return [list $textchunks {*}$params] - } - string { - #todo - flag to disable indent-matching behaviour for multiline param? - set out "" - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach pt $textchunks param $params { - if {$opt_paramindents eq "none"} { - append out $pt $param - } else { - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - if {$opt_paramindents eq "line"} { - regexp {(\s*).*} $lastline _all lastindent - } else { - #position - #TODO - detect if there are grapheme clusters - #This regsub doesn't properly space unicode double-wide chars or clusters - set lastindent "[regsub -all {\S} $lastline " "] " - } - if {$lastindent ne ""} { - set paramlines [split $param \n] - if {[llength $paramlines] == 1} { - append out $pt $param - } else { - append out $pt [lindex $paramlines 0] - foreach nextline [lrange $paramlines 1 end] { - append out \n $lastindent $nextline - } - } - } else { - append out $pt $param - } - append lastline $param - } - } - return $out - } - } - } - #test single placeholder tstr args where single placeholder must be an int - proc tstr_test_one {args} { - set argd [punk::args::get_dict { - @cmd -name ::punk::args::lib::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 -return args {Select * from table where id = \$\{$id\} and etc... ;}] - } - - @values -min 2 -max 2 - template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - - but the tstr call in the example 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]] ""] - set result [string cat [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 dollar sign - 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]] - } - - #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. - proc indent {text {prefix " "}} { - set result [list] - foreach line [split $text \n] { - if {[string trim $line] eq ""} { - lappend result "" - } else { - lappend result $prefix[string trimright $line] - } - } - return [join $result \n] - } - #dedent? - proc undent {text} { - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - regexp {^([\t ]*)} $lcp _m lcp - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - - #hacky - proc undentleader {text leader} { - #leader usually whitespace - but doesn't have to be - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - lappend nonblank "${leader}!!" - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - #regexp {^([\t ]*)} $lcp _m lcp - #lcp can be shorter than leader - set lcp [string range $lcp 0 [string length $leader]-1] - - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - #A version of textutil::string::longestCommonPrefixList - proc longestCommonPrefix {items} { - if {[llength $items] <= 1} { - return [lindex $items 0] - } - set items [lsort $items[unset items]] - set min [lindex $items 0] - set max [lindex $items end] - #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) - #(sort order nothing to do with length - e.g min may be longer than max) - if {[string length $min] > [string length $max]} { - set temp $min - set min $max - set max $temp - } - set n [string length $min] - set prefix "" - set i -1 - while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { - append prefix $c - } - return $prefix - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] -} - -tcl::namespace::eval punk::args::argdocbase { - namespace export * - #use a? to test and create literal ansi here rather than relying on punk::ansi package presence - #e.g - #% a? bold - #- bold │SGR 1│sample│␛[1msample - #- ──────┼─────┼──────┼────────── - #- RESULT│ │sample│␛[1msample - proc B {} {return \x1b\[1m} ;#a+ bold - proc N {} {return \x1b\[22m} ;#a+ normal - proc I {} {return \x1b\[3m} ;#a+ italic - proc NI {} {return \x1b\[23m} ;#a+ noitalic - -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::package { - variable PUNKARGS - lappend PUNKARGS [list { - @dynamic - @id -id "::punk::args::package::standard_about" - @cmd -name "%pkg%::about" -help\ - "About %pkg% - ... - " - -package_about_namespace -type string -optional 0 -help\ - "Namespace containing the package about procedures - Must contain " - -return\ - -type string\ - -default table\ - -choices {string table tableobject}\ - -choicelabels { - string\ - "A basic text layout" - table\ - "layout in table borders - (requires package: textblock)" - tableobject\ - "textblock::class::table object instance" - }\ - -help\ - "Choose the return type of the 'about' information" - topic -optional 1\ - -nocase 1\ - -default {*}\ - -choices {Description License Version Contact *}\ - -choicerestricted 0\ - -choicelabels { - - }\ - -multiple 1\ - -help\ - "Topic to display. Omit or specify as * to see all. - If * is included with explicit topics, * represents - the remaining unmentioned topics." - }] - proc standard_about {args} { - set argd [punk::args::parse $args withid ::punk::args::package::standard_about] - lassign [dict values $argd] leaders OPTS values received - - set pkgns [dict get $OPTS -package_about_namespace] - if {[info commands ${pkgns}::package_name] eq ""} { - error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" - } - set pkgname [${pkgns}::package_name] - - set opt_return [dict get $OPTS -return] - set all_topics [${pkgns}::about_topics] - if {![dict exists $received topic]} { - set topics $all_topics - } else { - # * represents all remaining topics not explicitly mentioned. - set val_topics [dict get $values topic] ;#if -multiple is true, this is a list - set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] - set topics [list] - foreach t $val_topics { - if {$t eq "*"} { - foreach a $all_topics { - if {$a ni $explicit_topics} { - lappend topics $a - } - } - } else { - lappend topics $t - } - } - } - if {$opt_return ne "string"} { - package require textblock ;#table support - set is_table 1 - set title [string cat {[} $pkgname {]} ] - set t [textblock::class::table new -title $title] - $t configure -frametype double -minwidth [expr {[string length $title]+2}] - - } else { - set topiclens [lmap t $topics {string length $t}] - set widest_topic [tcl::mathfunc::max {*}$topiclens] - set is_table 0 - set about "$pkgname\n" - append about [string repeat - $widest_topic] \n - } - foreach topic $topics { - if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { - set topic_contents [::${pkgns}::get_topic_$topic] - } else { - set topic_contents "" - } - if {!$is_table} { - set content_lines [split $topic_contents \n] - append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n - foreach ln [lrange $content_lines 1 end] { - append about [format %-${widest_topic}s ""] " " $ln \n - } - } else { - $t add_row [list $topic $topic_contents] - } - } - - if {!$is_table} { - return $about - } else { - if {$opt_return eq "tableobject"} { - return $t - } - set result [$t print] - $t destroy - return $result - } - } - -} - -#usually we would directly call arg definitions near the defining proc, -# so that the proc could directly use the definition in its parsing. -# -#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. -#arguably it may be more processor-cache-efficient to do together like this anyway. - -#can't do this here? - as there is circular dependency with punk::lib -#tcl::namespace::eval punk::args { -# foreach deflist $PUNKARGS { -# punk::args::define {*}$deflist -# } -# set PUNKARGS "" -#} - -lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -tcl::namespace::eval punk::args::system { - #*** !doctools - #[subsection {Namespace punk::args::system}] - #[para] Internal functions that are not part of the API - - #dict get value with default wrapper for tcl 8.6 - if {[info commands ::tcl::dict::getdef] eq ""} { - proc Dict_getdef {dictValue args} { - set keys [lrange $args 0 end-1] - if {[tcl::dict::exists $dictValue {*}$keys]} { - return [tcl::dict::get $dictValue {*}$keys] - } else { - return [lindex $args end] - } - } - } else { - #we pay a minor perf penalty for the wrap - interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef - } - - #name to reflect maintenance - home is punk::lib::ldiff - proc punklib_ldiff {fromlist removeitems} { - if {[llength $removeitems] == 0} {return $fromlist} - set result {} - foreach item $fromlist { - if {$item ni $removeitems} { - lappend result $item - } - } - return $result - } - -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::args [tcl::namespace::eval punk::args { - tcl::namespace::path {::punk::args::lib ::punk::args::system} - variable pkg punk::args - variable version - set version 0.1.4 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.6.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.6.tm deleted file mode 100644 index c3bf04b8..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.6.tm +++ /dev/null @@ -1,6400 +0,0 @@ -# -*- 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: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.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 punk::args 0.1.6 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.1.6] -#[copyright "2024"] -#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] -#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] -#[require punk::args] -#[keywords module proc args arguments parse] -#[description] -#[para]Utilities for parsing proc args - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). -#[para] overview of punk::args -#[subsection Concepts] -#[para]There are 2 main conventions for parsing a proc args list -#[list_begin enumerated] -#[enum] -#[para]leading option-value pairs and flags followed by a list of values (Tcl style) -#[enum] -#[para]leading list of values followed by option-value pairs and flags (Tk style) -#[list_end] -#[para]There are exceptions in both Tcl and Tk commands regarding this ordering -#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style -#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] -#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. -#[para] -#[para]The basic principle is that a call to punk::args::parse is made near the beginning of the proc with a cacheable argument defining the parameters e.g -#[example { -# proc dofilestuff {args} { -# lassign [dict values [punk::args::parse $args withdef { -# @cmd -help "do some stuff with files e.g dofilestuff " -# @opts -type string -# #comment lines ok -# -directory -default "" -# -translation -default binary -# #setting -type none indicates a flag that doesn't take a value (solo flag) -# -nocomplain -type none -# @values -min 1 -max -1 -# }]] leaders opts values -# -# puts "translation is [dict get $opts -translation]" -# foreach f [dict values $values] { -# puts "doing stuff with file: $f" -# } -# } -#}] -#[para]The lines beginning with @ are usually optional in most cases and can be used to set defaults and some extra controls -#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values -#[para]valid @ lines being with @cmd @leaders @opts @values -#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. -#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. -#[para]e.g the result from the punk::args::parse call above may be something like: -#[para] leaders {} opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} -#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments -#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments -#[para]This could also be implemented entirely using args - and the @leaders category of arguments -#[example { -# proc dofilestuff {category args} { -# lassign [dict values [punk::args::parse $args withdef { -# @id -id ::dofilestuff -# -directory -default "" -# -translation -default binary -# -nocomplain -type none -# @values -min 2 -max 2 -# fileA -type existingfile 1 -# fileB -type existingfile 1 -# }]] leaders opts values -# puts "$category fileA: [dict get $values fileA]" -# puts "$category fileB: [dict get $values fileB]" -# } -#}] -#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 -#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored -#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, -#[para] or an additional call could be made to punk::args e.g -#[example { -# punk::args::parse [list $category $another_leading_arg] withdef { -# category -choices {cat1 cat2 cat3} -# another_leading_arg -type boolean -# } -#}] - -#*** !doctools -#[subsection Notes] -#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. -#[para] -#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. -#For functions that are part of an API a package may be more suitable. -#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) -#[example { -# proc test_switch {args} { -# set opts [dict create\\ -# -return "object"\\ -# -frametype "heavy"\\ -# -show_edge 1\\ -# -show_seps 0\\ -# -x a\\ -# -y b\\ -# -z c\\ -# -1 1\\ -# -2 2\\ -# -3 3\\ -# ] -# foreach {k v} $args { -# switch -- $k { -# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { -# dict set opts $k $v -# } -# default { -# error "unrecognised option '$k'. Known options [dict keys $opts]" -# } -# } -# } -# return $opts -# } -#}] -#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. -#[para] -# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. -# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. -#[para]use punk::lib::show_jump_tables to verify that a jump table exists. -#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous -#[example { -# proc test_prefix {args} { -# set opts [dict create\ -# -return string\ -# -frametype \uFFEF\ -# -show_edge \uFFEF\ -# -show_seps \uFFEF\ -# -x a\ -# -y b\ -# -z c\ -# -1 1\ -# -2 2\ -# -3 3\ -# ] -# if {[llength $args]} { -# set knownflags [dict keys $opts] -# } -# foreach {k v} $args { -# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v -# } -# return $opts -# } -#}] -#[para]There are many alternative args parsing packages a few of which are listed here. -#[list_begin enumerated] -#[enum]argp (pure tcl) -#[enum]parse_args (c implementation) -#[enum]argparse (pure tcl *) -#[enum]cmdline (pure tcl) -#[enum]opt (pure tcl) distributed with Tcl but considered deprecated -#[enum]The tcllib set of TEPAM modules (pure tcl) -#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. -#[list_end] -#[para] (* c implementation planned/proposed) -#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. -#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences -#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. -#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. -#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. -#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. -#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -#All ensemble commands are slower in a safe interp as they aren't compiled the same way -#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 -#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. -#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) -#ensembles: array binary clock dict info namespace string -#possibly file too, although that is generally hidden/modified in a safe interp -#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc -#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::args -#[list_begin itemized] -package require Tcl 8.6- -#optional? punk::trie -#optional? punk::textblock -#*** !doctools -#[item] [package {Tcl 8.6-}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -tcl::namespace::eval punk::args::register { - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] cooperative namespace punk::args::register - #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded - #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. - #[list_begin definitions] - - #Although the actual punk::args::define calls are not too sluggish, there could be *many*. - #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, - #especially since a fair proportion may be for documentation purposes rather than parsing args. - - # -- --- --- --- --- --- --- --- - #cooperative with packages that define some punk args but do so lazily - #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first - variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective - if {![info exists ::punk::args::register::NAMESPACES]} { - set ::punk::args::register::NAMESPACES [list] - } - # -- --- --- --- --- --- --- --- - - variable loaded_packages - if {![info exists loaded_packages]} { - set loaded_packages [list] ;#fully loaded - } - variable loaded_info - if {![info exists loaded_info]} { - set loaded_info [dict create] ;#time - } - variable scanned_packages - if {![info exists scanned_packages]} { - set scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages - } - variable scanned_info ;#time and idcount - if {![info exists scanned_info]} { - set scanned_info [dict create] - } - #some packages, e.g punk::args::tclcore document other namespaces. - #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources - variable namespace_docpackages - if {![info exists namespace_docpackages]} { - set namespace_docpackages [dict create] - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::register ---}] -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args { - - - variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. - - tcl::namespace::export {[a-z]*} - variable rawdef_cache - if {![info exists rawdef_cache]} { - set rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} - } - variable id_cache_rawdef - if {![info exists id_cache_rawdef]} { - set id_cache_rawdef [tcl::dict::create] - } - variable id_cache_spec - if {![info exists id_cache_spec]} { - set id_cache_spec [tcl::dict::create] - } - - variable argdefcache_unresolved - if {![info exists argdefcache_unresolved]} { - set argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) - } - - variable argdata_cache - if {![info exists argdata_cache]} { - set argdata_cache [tcl::dict::create] - } - - variable id_counter - if {![info exists id_counter]} { - set id_counter 0 - } - - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] Core API functions for punk::args - #[list_begin definitions] - - #todo - some sort of punk::args::cherrypick operation to get spec from an existing set - #todo - doctools output from definition - - - - - #todo? -synonym/alias ? (applies to opts only not values) - #e.g -background -aliases {-bg} -default White - #review - how to make work with trie prefix - #e.g - # -corner -aliases {-corners} - # -centre -aliases {-center -middle} - #We mightn't want the prefix to be longer just because of an alias - #we should get -co -ce and -m from the above as abbreviations - - set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] - - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::define - #todo @preamble -help "move large block outside of table?" - @cmd -name punk::args::define -help\ - "Accepts a line-based definition of command arguments. - The definition can be supplied as a single text block or multiple as described - in the help information for 'text' below. - - Returns an id which is a key to the stored definition. - The id is taken from the supplied definition's @id -id line, or is an - automatically created id of the form 'autoid_'. - - At the time define is called - just the raw text arguments are stored for the id. - When the id is first used, for example with 'punk::args::parse $args withid $id', - the raw definition is parsed into a stored specifications dictionary. - - This specifications dictionary is structured for (optional) use within commands to - parse and validate the arguments - and is also used when retrieving definitions - (or parts thereof) for re-use. - - This can be used purely for documentation or called within a function to parse a mix - of leading values, switches/flags and trailing values. - - The overhead is favourably comparable with other argument processors - but none are - as fast as minimal code with a switch statement. For toplevel commands where a few - 10s of microseconds is immaterial, the validation and automated error formatting in - a table can be well worthwhile. For inner procs requiring utmost speed, the call can - be made only on the unhappy path when basic processing determines a mismatch - or it - can be left entirely as documentation for interactive use with: i ... - and for synopsis generation with: s ... - - The definition should usually contain an initial line of the form: @id -id ::somecmd - - Blank lines are ignored at the top level, ie if they are not part of another structure. - Similarly - lines at the top level beginning with the # character are ignored. - All other toplevel lines must consist of a leading word followed by paired arguments. - The arguments can be spread over multiple lines and contain lines of near-arbitrary - text if they are properly braced or double quoted and Tcl escaping for inner quotes - or unbalanced braces is maintained. - The line continuation character - (\\ at the end of the line) can be used to continue the set of arguments for - a leading word. - Leading words beginning with the @ character are directives controlling argument - parsing, defaults for subsequent arguments, and help display. - directives include: - %B%@id%N% ?opt val...? - directive-options: -id - %B%@cmd%N% ?opt val...? - directive-options: -name -help - %B%@leaders%N% ?opt val...? - directive-options: -min -max - (used for leading args that come before switches/opts) - %B%@opts%N% ?opt val...? - directive-options: -any - %B%@values%N% ?opt val...? - directive-options: -min -max - (used for trailing args that come after switches/opts) - %B%@form%N% ?opt val...? - directive-options: -form -synopsis - (used for commands with multiple forms) - The -synopsis value allows overriding the auto-calculated - synopsis. - %B%@formdisplay%N% ?opt val...? - directive-options: -header (text for header row of table) - -body (override autogenerated arg info for form) - %B%@doc%N% ?opt val...? - directive-options: -name -url - %B%@seealso%N% ?opt val...? - directive-options: -name -url (for footer - unimplemented) - - Some other options normally present on custom arguments are available - to use with the @leaders @opts @values directives to set defaults - for subsequent lines that represent your custom arguments. - These 3 directives should occur in exactly this order - but can be - repeated with custom argument lines interspersed. - - An @id line can only appear once and should be the first item. - For the commandline usage to be displayed either on parsing error - or using the i .. function - an @id with -id is needed. - - All directives can be omitted, in which case every line represents - a custom leader, value or option. - All will be leaders by default if no options defined. - If options are defined (by naming with leading dash, or explicitly - specifying @opts) then the definitions prior to the options will be - categorised as leaders, and those following the options will be - categorised as values. - - Custom arguments are defined by using any word at the start of a - line that doesn't begin with @ or - - (except that adding an additionl @ escapes this restriction so - that @@somearg becomes an argument named @somearg) - - custom leading args, switches/options (names starting with -) - and trailing values also take spec-options: - - -type - defaults to string. If no other restrictions - are specified, choosing string does the least validation. - recognised types: - none - (used for switches only. Indicates this is - a 'solo' flag ie accepts no value) - int|integer - list - indexexpression - dict - double - bool|boolean - char - file - directory - string - ansistring - globstring - (any of the types accepted by 'string is') - - These all perform some validation checks - - and more.. (todo - document here) - - -optional - (defaults to true for flags/switches false otherwise) - For non flag/switch arguments - all arguments with - -optional true must sit consecutively within their group. - ie all optional leader arguments must be together, and all - optional value arguments must be together. Furthermore, - specifying both optional leaders and optional values will - often lead to ambiguous parsing results. Currently, all - optional non-flg/switch arguments should be either at the - trailing end of leaders or the trailing end of values. - Further unambiguous arrangements of optional args may be - made in future - but are currently considered 'unsupported' - -default - -multiple (for leaders & values defines whether - subsequent received values are stored against the same - argument name - only applies to final leader OR final value) - (for options/flags this allows the opt-val pair or solo - flag to appear multiple times - not necessarily contiguously) - -choices {} - A list of allowable values for an argument. - The -default value doesn't have to be in the list. - If a -type is specified - it doesn't apply to choice members. - It will only be used for validation if the -choicerestricted - option is set to false. If all choices are specified in values - within the -choicegroups dict, it is not necessary to specify them - in the -choices list. It is effectively a simpler form of - specifying choices when no grouping is required. It is fine to - use both -choices and -choicegroups e.g specifying all in -choices - and then including only some that need grouping in -choicegroups. - -choicelabels {} - keys are the values/argument names from -choices (or equivalently - members of value entries from the -choicegroups dict) - The values in the choicelabels dict are text values, possibly - containing newlines, that are displayed below each choice. - This is commonly a very basic summary of the choice. In the - case of a subcommand it may be a usage synopsis for further - arguments. - -choicerestricted - Whether values not specified in -choices or -choicegroups are - allowed. Defaults to true. - -choiceprefix - This specifies whether unique prefixes are able to be used - instead of the complete string. This is calculated using - tcl::prefix::match - and will display in the autogenerated - usage output. Defaults to true. - -choiceprefixdenylist {} - These choices should match exactly a choice entry in one of - the settings -choices or -choicegroups. - These will still be used in prefix calculation - but the full - choice argument must be entered to select the choice. - -choicegroups {} - Generally this would be used instead of -choices to allow - usage display of choices grouped by some name (or the empty - string for 'ungrouped' items which appear first). - See for example the output if 'i zlib' where choices of the - next subcommand are grouped by the names compression,channel, - streaming and checksumming. The -choices list is equivalent - to a -choicegroups dict entry where the key (groupname) is - the empty string. Both may be specified, in which case the - final list of available choices will be a union of the listed - values in -choices and the values from each choice group. - Choice values specified in -choices are effectively ungrouped - unless overridden by placing them in a choicegroup. - -choicemultiple (default {1 1}) - is a pair representing min and max number of choices - that can be present in the value. - If is a single integer it is equivalent to a - specified with the same integer for both min and max. - Max of -1 represents no upper limit. - If allows more than one choice the value is a list - consisting of items in the choices made available through - entries in -choices/-choicegroups. - -minsize (type dependant) - -maxsize (type dependant) - -range (type dependant) - - - " - -dynamic -type boolean -default 0 -help\ - "If -dynamic is true, tstr interpolations of the form \$\{\$var\} - are re-evaluated on each call. - If the definition is being used not just as documentation, but is also - used within the function to parse args, e.g using punk::args::get_by_id, - then it should be noted that there is a slight performance penalty for the - dynamic case. - It is often not significant, perhaps depending on what vars/commands are - used but -dynamic true might be less desirable if the command is used in - inner loops in more performance-sensitive code. - " - @values -min 1 -max -1 - text -type string -multiple 1 -help\ - "Block(s) of text representing the argument definition for a command. - At least one must be supplied. If multiple, they are joined together with \\n. - Using multiple text arguments may be useful to mix curly-braced and double-quoted - strings to have finer control over interpolation when defining arguments. - (this can also be handy for sections that pull resolved definition lines - from existing definitions (by id) for re-use of argument specifications and help text) - - e.g the following definition passes 2 blocks as text arguments - definition { - @id -id ::myns::myfunc - @cmd -name myns::myfunc -help\\ - \"Description of command\" - - #The following option defines an option-value pair - -option1 -default blah -type string - #The following option defines a flag style option (solo) - -flag1 -default 0 -type none -help\\ - \"Info about flag1 - subsequent help lines auto-dedented by whitespace to left - of corresponding record start (in this case -flag1) - + first 4 spaces if they are all present. - This line has no extra indent relative to first line 'Info about flag1' - This line indented a further 6 chars\" - - @values -min 1 -max -1 - #Items that don't begin with * or - are value definitions - v1 -type integer -default 0 - thinglist -type string -multiple 1 - } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" - " - }]] - - proc New_command_form {name} { - #probably faster to inline a literal dict create in the proc than to use a namespace variable - set leaderspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - -ensembleparameter 0\ - ] - set optspec_defaults [tcl::dict::create\ - -type string\ - -optional 1\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - -prefix 1\ - ] - set valspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - - #form record can have running entries such as 'argspace' that aren't given to arg parser - #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict - return [dict create\ - argspace "leaders"\ - ARG_INFO [tcl::dict::create]\ - ARG_CHECKS [tcl::dict::create]\ - LEADER_DEFAULTS [tcl::dict::create]\ - LEADER_REQUIRED [list]\ - LEADER_NAMES [list]\ - LEADER_MIN ""\ - LEADER_MAX ""\ - LEADERSPEC_DEFAULTS $leaderspec_defaults\ - LEADER_CHECKS_DEFAULTS {}\ - OPT_DEFAULTS [tcl::dict::create]\ - OPT_REQUIRED [list]\ - OPT_NAMES [list]\ - OPT_ANY 0\ - OPT_SOLOS {}\ - OPTSPEC_DEFAULTS $optspec_defaults\ - OPT_CHECKS_DEFAULTS {}\ - VAL_DEFAULTS [tcl::dict::create]\ - VAL_REQUIRED [list]\ - VAL_NAMES [list]\ - VAL_MIN ""\ - VAL_MAX ""\ - VALSPEC_DEFAULTS $valspec_defaults\ - VAL_CHECKS_DEFAULTS {}\ - FORMDISPLAY [tcl::dict::create]\ - ] - - } - - proc errorstyle {args} { - #set or query the running config -errorstyle - #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? - #values: - #debug, enhanced, standard, basic, minimal - error todo - } - proc define {args} { - variable rawdef_cache - variable id_cache_rawdef - variable argdata_cache - if {[dict exists $rawdef_cache $args]} { - return [dict get [dict get $rawdef_cache $args] -id] - } else { - set id [rawdef_id $args] - if {[id_exists $id]} { - #we seem to be re-creating a previously defined id... - #clear any existing caches for this id - puts stderr "punk::args::define Redefinition of id:$id - clearing existing data" - - #dict unset argdata_cache $prevraw ;#silently does nothing if key not present - dict for {k v} $argdata_cache { - if {[dict get $v id] eq $id} { - dict unset argdata_cache $k - } - } - dict for {k v} $rawdef_cache { - if {[dict get $v -id] eq $id} { - dict unset rawdef_cache $k - } - } - dict unset id_cache_rawdef $id - } - set is_dynamic [rawdef_is_dynamic $args] - set defspace [uplevel 1 {::namespace current}] - dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic -defspace $defspace] - dict set id_cache_rawdef $id $args - return $id - } - } - - proc idquery_info {id} { - variable id_cache_rawdef - variable rawdef_cache - if {[dict exists $id_cache_rawdef $id]} { - set sep [string repeat - 40] - set rawdef [dict get $id_cache_rawdef $id] - if {[dict exists $rawdef_cache $rawdef]} { - set idinfo [dict get $rawdef_cache $rawdef] - } else { - set idinfo "" - } - set result "raw definition:" - append result \n $sep - append result \n $rawdef - append result \n $sep - append result \n "id info:" - append result \n $idinfo - append result \n $sep - variable argdata_cache - #lsearch -stride not avail (or buggy) in some 8.6 interps - search manually for now (2025). todo - modernize some time after Tcl 9.0/9.1 more widespread.(2027?) - #check for and report if id is present multiple times - set argdata_records [list] - dict for {k v} $argdata_cache { - if {[dict get $v id] eq $id} { - if {$k eq $rawdef} { - lappend argdata_records [list 1 $k $v] - } else { - lappend argdata_records [list 0 $k $v] - } - } - } - append result \n "argdata cache:" - if {![llength $argdata_records]} { - append result \n "(not present)" - } else { - append result \n "present [llength $argdata_records] time(s)" - foreach r $argdata_records { - lassign $r match k v - if {$match} { - append result \n " - present with same rawdef key" - } else { - append result \n " - present with different rawdef key" - append result \n " [punk::lib::indent $k { }]" - } - } - if {[llength $argdata_records] > 1} { - append result \n "*more than one record was not expected - review*" - } - } - append result \n $sep - return $result - } - } - - proc define2 {args} { - dict get [resolve {*}$args] id - } - - proc resolve {args} { - variable rawdef_cache - variable id_cache_rawdef - set defspace "" - if {[dict exists $rawdef_cache $args]} { - set cinfo [dict get $rawdef_cache $args] - set id [dict get $cinfo -id] - set is_dynamic [dict get $cinfo -dynamic] - if {[dict exists $cinfo -defspace]} { - set defspace [dict get $cinfo -defspace] - } - } else { - #should we really be resolving something that hasn't been defined? - set id [rawdef_id $args] - puts stderr "Warning: punk::args::resolve called with undefined id:$id" - set is_dynamic [rawdef_is_dynamic $args] - dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] - dict set id_cache_rawdef $id $args - } - - - variable argdata_cache - variable argdefcache_unresolved - - - set cache_key $args - #ideally we would use a fast hash algorithm to produce a short key with low collision probability. - #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) - #review - check if there is a built-into-tcl way to do this quickly - #for now we will just key using the whole string - #performance seems ok - memory usage probably not ideal - #quote from DKF 2021 - #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. - #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. - #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. - #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). - #> If dealing with very large amounts of data, using a database is probably a good plan. - - set textargs $args - if {![llength $args]} { - punk::args::get_by_id ::punk::args::define {} - return - } - #if {[lindex $args 0] eq "-dynamic"} { - # set is_dynamic [lindex $args 1] - # set textargs [lrange $args 2 end] - #} - - #experimental - set LVL 2 - - if {!$is_dynamic} { - if {[tcl::dict::exists $argdata_cache $cache_key]} { - return [tcl::dict::get $argdata_cache $cache_key] - } - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - if {[string first \$\{ $optionspecs] > 0} { - if {$defspace ne ""} { - #normal/desired case - set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } else { - #todo - deprecate/stop from happening? - puts stderr "punk::args::resolve calling tstr for id:$id with no known definition space (-defspace empty)" - set optionspecs [uplevel $LVL [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } - } - } else { - - if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { - set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel $LVL [list ::subst $param]] - } - } else { - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - #dynamic - double substitution required. - #e.g - # set DYN_CHOICES {${[::somewhere::get_choice_list]}} - # set RED [punk::ansi::a+ bold red] - # set RST [punk::ansi::a] - # punk::args::define { - # -arg -choices {${$DYN_CHOICES}} -help "${$RED}important info${$RST}" - #} - if {$defspace ne ""} { - set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } - #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) - if {[string first \$\{ $optionspecs] > 0} { - set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel $LVL [list ::subst $param]] - } - tcl::dict::set argdefcache_unresolved $cache_key $pt_params - } - } - #argdata_cache should be limited in some fashion or will be a big memory leak??? - if {[tcl::dict::exists $argdata_cache $optionspecs]} { - #resolved cache version exists - return [tcl::dict::get $argdata_cache $optionspecs] - } - } - - - - #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices - #default to 1 for convenience - - #checks with no default - #-minsize -maxsize -range - - - #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi - #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist - - #set opt_defaults [tcl::dict::create] - #set val_defaults [tcl::dict::create] - - #set opt_solos [list] - #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end - - set records [list] - set linebuild "" - - set linelist [split $optionspecs \n] - set lastindent "" - foreach ln $linelist { - if {[tcl::string::trim $ln] eq ""} {continue} - regexp {(\s*).*} $ln _all lastindent - break ;#break at first non-empty - } - #puts "indent1:[ansistring VIEW $lastindent]" - set in_record 0 - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - foreach rawline $linelist { - set recordsofar [tcl::string::cat $linebuild $rawline] - #ansi colours can stop info complete from working (contain square brackets) - #review - when exactly are ansi codes allowed/expected in record lines. - # - we might reasonably expect them in default values or choices or help strings - # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. - # - eg set line "set x \"a[a+ red]red[a]\"" - # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket - if {$has_punkansi} { - set test_complete [punk::ansi::ansistrip $recordsofar] - } else { - #review - #we only need to strip enough to stop interference with 'info complete' - set test_complete [string map [list \x1b\[ ""] $recordsofar] - } - if {![tcl::info::complete $test_complete]} { - #append linebuild [string trimleft $rawline] \n - if {$in_record} { - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. - #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. - #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. - #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) - #(note string first "" $str is fast and returns -1) - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline \n - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline \n - } else { - append linebuild $rawline \n - } - } else { - set in_record 1 - regexp {(\s*).*} $rawline _all lastindent - #puts "indent: [ansistring VIEW -lf 1 $lastindent]" - #puts "indent from rawline:$rawline " - append linebuild $rawline \n - } - } else { - set in_record 0 - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline - } else { - append linebuild $rawline - } - lappend records $linebuild - set linebuild "" - } - } - set cmd_info {} - set package_info {} - set id_info {} ;#e.g -children ?? - set doc_info {} - #set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table - set seealso_info {} - set keywords_info {} - ###set leader_min 0 - ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit - #set leader_max "" - #(common case of no leaders specified) - #set opt_any 0 - #set val_min 0 - #set val_max -1 ;#-1 for no limit - set DEF_definition_id $id - - #form_defs - set F [dict create _default [New_command_form _default]] - set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under - - #set ARGSPACE [dict create] ;#keyed on form - #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values - - set refs [dict create] - set record_type "" - set record_number -1 ;# - foreach rec $records { - set trimrec [tcl::string::trim $rec] - switch -- [tcl::string::index $trimrec 0] { - "" - # {continue} - } - incr record_number - set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict - if {[llength $record_values] % 2 != 0} { - #todo - avoid raising an error - store invalid defs keyed on id - error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" - } - # ---------------------------------------------------------- - # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. - #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! - #(form_ids_active is otherwise set in the @form handling block) - - #consider the following 2 line entry which is potentially dynamically included via a tstr: - # @form -form {* newform} - # @form -form {newform} -synopsis "cmd help ?stuff?" - #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. - #(because _default is usually 'taken over' by the first encountered form id) - #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record - #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. - - if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { - set patterns [dict get $record_values -form] - set record_form_ids [list] - foreach p $patterns { - if {[regexp {[*?\[\]]} $p]} { - #isglob - only used for matching existing forms - lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] - } else { - #don't test for existence - will define new form if necessary - lappend record_form_ids $p - } - } - #-form values could be globs that didn't match. record_form_ids could be empty.. - if {[llength $record_form_ids]} { - #only rename _default if it's the sole entry - if {[dict size $F] == 1 && [dict exists $F "_default"]} { - if {"_default" ni $record_form_ids} { - #only initial form exists - but we are mentioning new ones - #first rename the _default to first encountered new form id - #(just replace whole dict with new key - same data) - set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] - #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F - #we are only setting active because of the rename - @form is the way to change active forms list - set form_ids_active [lindex $record_form_ids 0] - } - } - foreach fid $record_form_ids { - if {![dict exists $F $fid]} { - if {$firstword eq "@form"} { - #only @form directly supplies keys - dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] - } else { - dict set F $fid [New_command_form $fid] - } - } else { - #update form with current record opts, except -form - if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } - } - } - } - } else { - #missing or empty -form - set record_form_ids $form_ids_active - if {$firstword eq "@form"} { - foreach fid $form_ids_active { - dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] - } - } - } - # ---------------------------------------------------------- - - set firstchar [tcl::string::index $firstword 0] - set secondchar [tcl::string::index $firstword 1] - if {$firstchar eq "@" && $secondchar ne "@"} { - set record_type "directive" - set directive_name $firstword - set at_specs $record_values - - switch -- [tcl::string::range $directive_name 1 end] { - dynamic { - set is_dynamic 1 - } - id { - #disallow duplicate @id line ? - #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) - - #id An id will be allocated if no id line present or the -id value is "auto" - - if {[dict exists $at_specs -id]} { - set thisid [dict get $at_specs -id] - if {$thisid ni [list $id auto]} { - error "punk::args::define @id mismatch existing: $id vs $thisid" - } - } - set id_info $at_specs - } - ref { - #a reference within the definition - #e.g see punk::args::tclcore ::after - #global reference dict - independent of forms - #ignore refs without an -id - #store all keys except -id - #complete overwrite if refid repeated later on - if {[dict exists $at_specs -id]} { - dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] - } - } - default { - #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple - #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) - #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) - #That is possibly too complicated and/or unnecessary? - #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? - - if {[dict exists $at_specs -id]} { - set copyfrom [get_spec [dict get $at_specs -id]] - #we don't copy the @id info from the source - #for now we only copy across if nothing set.. - #todo - bring across defaults for empty keys at targets? - #need to keep it simple enough to reason about behaviour easily.. - if {[dict size $copyfrom]} { - if {![dict size $cmd_info]} { - set cmd_info [dict get $copyfrom cmd_info] - } - if {![dict size $doc_info]} { - set doc_info [dict get $copyfrom doc_info] - } - - #foreach fid $record_form_ids { - # #only use elements with matching form id? - # #probably this feature mainly useful for _default anyway so that should be ok - # #cooperative doc sets specified in same file could share via known form ids too - # FORMDISPLAY has keys -header -body - # if {![dict size $F $fid $FORMDISPLAY]} { - # if {[dict exists $copyfrom FORMS $fid FORMDISPLAY]} { - # dict set F $fid FORMDISPLAY [dict get $copyfrom FORMS $fid FORMDISPLAY] - # } - # } - # #TODO - # #create leaders opts vals depending on position of @default line? - # #options on @default line to exclude/include sets??? - #} - } - } - } - form { - # arity system ? - #handle multiple parsing styles based on arities and keyword positions (and/or flags?) - #e.g see lseq manual with 3 different parsing styles. - #aim to produce a table/subtable for each - # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ - # -arities { - # 2 - # {3 anykeys {1 .. 1 to}} - # {4 anykeys {3 by}} - # {5 anykeys {1 .. 1 to 3 by}} - # }\ - # -fallback 1 - # ... - # @parser -synopsis "start 'count' count ??'by'? step?"\ - # -arities { - # {3 anykeys {1 count}} - # } - # ... - # @form -synopsis "count ?'by' step?"\ - # -arities { - # 1 - # {3 anykeys {1 by}} - # } - # - # see also after manual - # @form -arities {1} - # @form -arities { - # 1 anykeys {0 info} - # } - #todo - - #can we generate a form synopsis if -synopsis not supplied? - - #form id can be list of ints|names?, or * - if {[dict exists $at_specs -form]} { - set idlist [dict get $at_specs -form] - if {$idlist eq "*"} { - #* only applies to form ids that exist at the time - set idlist [dict keys $F] - } - set form_ids_active $idlist - } - #new form keys already created if they were needed (done for all records that have -form ) - } - package { - set package_info [dict merge $package_info $at_specs] - } - cmd { - #allow arbitrary - review - set cmd_info [dict merge $cmd_info $at_specs] - } - doc { - set doc_info [dict merge $doc_info $at_specs] - } - formdisplay { - #override the displayed argument table for the form. - #(formdisplay keys -header -body) - #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing - foreach fid $record_form_ids { - tcl::dict::set F $fid FORMDISPLAY [dict merge [tcl::dict::get $F $fid FORMDISPLAY] $at_specs] - } - } - opts { - foreach fid $record_form_ids { - if {[tcl::dict::get $F $fid argspace] eq "values"} { - error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" - } - tcl::dict::set F $fid argspace "options" - set tmp_optspec_defaults [dict get $F $fid OPTSPEC_DEFAULTS] - - foreach {k v} $at_specs { - switch -- $k { - -form { - #review - handled above - } - -any - - -anyopts { - #set opt_any $v - tcl::dict::set F $fid OPT_ANY $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { - #review - only apply to certain types? - tcl::dict::set tmp_optspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_optspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - index { - set v indexexpression - } - none - "" - - - any - ansistring - globstring - list { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_optspec_defaults -type $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple - - -prefix { - #allow overriding of defaults for options that occur later - tcl::dict::set tmp_optspec_defaults $k $v - } - default { - set known { -any -form -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" - } - } - } - tcl::dict::set F $fid OPTSPEC_DEFAULTS $tmp_optspec_defaults - } ;# end foreach record_form_ids - } - leaders { - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] in [list options values]} { - error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" - } - set tmp_leaderspec_defaults [dict get $F $fid LEADERSPEC_DEFAULTS] - - foreach {k v} $at_specs { - switch -- $k { - -form { - #review - handled above - } - -min - - -minvalues { - if {$v < 0} { - error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MIN $v - #if {$leader_max == 0} { - # set leader_max -1 - #} - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MAX $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -choiceinfo { - if {[llength $v] %2 != 0} { - error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - #-choicegroups? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_leaderspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - index { - set v indexexpression - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -ensembleparameter { - #review - tcl::dict::set tmp_leaderspec_defaults $k $v - #error "punk::args::define - -ensembleparameter not supported as a default for @leaders - only valid on actual leader arguments" - } - default { - set known { -min -form -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid LEADERSPEC_DEFAULTS $tmp_leaderspec_defaults - - } ;#end foreach record_form_ids - - } - values { - foreach fid $record_form_ids { - dict set F $fid argspace "values" - - set tmp_valspec_defaults [dict get $F $fid VALSPEC_DEFAULTS] - - foreach {k v} $at_specs { - switch -- $k { - -form { - #review - handled above - } - -min - - -minvalues { - if {$v < 0} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" - } - #set val_min $v - dict set F $fid VAL_MIN $v - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" - } - #set val_max $v - dict set F $fid VAL_MAX $v - } - -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_valspec_defaults $k $v - } - -choiceinfo - -choicegroups { - if {[llength $v] % 2 != 0} { - error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - # -choicegroups ?? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_valspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - index { - set v indexexpression - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set tmp_valspec_defaults $k $v - } - default { - set known { -min -form -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid VALSPEC_DEFAULTS $tmp_valspec_defaults - } - - } - seealso { - #todo! - #like @doc, except displays in footer, multiple - sub-table? - set seealso_info [dict merge $seealso_info $at_specs] - } - keywords { - #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? - set keywords_info [dict merge $keywords_info $at_specs] - } - default { - error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @formdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" - } - } - #record_type directive - continue - } elseif {$firstchar eq "-"} { - set argname $firstword - set argdef_values $record_values - tcl::dict::set argdef_values -ARGTYPE option - - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - dict set F $fid argspace "options" - } elseif {[dict get $F $fid argspace] eq "values"} { - error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" - } - set record_type option - dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] - #lappend opt_names $argname - } - - set is_opt 1 - } else { - set argname $firstword - if {$firstchar eq "@"} { - #allow basic @@ escaping for literal argname that begins with @ - set argname [tcl::string::range $argname 1 end] - } - - set argdef_values $record_values - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - set record_type leader - tcl::dict::set argdef_values -ARGTYPE leader - #lappend leader_names $argname - set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] - if {$argname ni $temp_leadernames} { - lappend temp_leadernames $argname - tcl::dict::set F $fid LEADER_NAMES $temp_leadernames - } else { - #This can happen if the definition has repeated values - error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" - } - - if {[dict get $F $fid LEADER_MAX] >= 0} { - if {[dict get $F $fid LEADER_MAX] < [llength $temp_leadernames]} { - puts stderr "punk::args::resolve warning arg $argname LEADER_MAX == [dict get $F $fid LEADER_MAX] but [llength $temp_leadernames] leader names found @id:$DEF_definition_id" - dict set F $fid LEADER_MAX [llength $temp_leadernames] - } - } - } else { - set record_type value - tcl::dict::set argdef_values -ARGTYPE value - set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] - if {$argname ni $temp_valnames} { - lappend temp_valnames $argname - tcl::dict::set F $fid VAL_NAMES $temp_valnames - } else { - error "punk::args::define - arg $argname already present as value in '$rec' (command form:'$fid') @id:$DEF_definition_id" - } - #lappend val_names $argname - if {[dict get $F $fid VAL_MAX] >= 0} { - if {[dict get $F $fid VAL_MAX] < [llength $temp_valnames]} { - puts stderr "punk::args::resolve warning arg $argname VAL_MAX == [dict get $F $fid VAL_MAX] but [llength $temp_valnames] value names found @id:$DEF_definition_id" - dict set F $fid VAL_MAX [llength $temp_valnames] - } - } - } - } - - set is_opt 0 - } - - - #assert - we only get here if it is a value or flag specification line. - #assert argdef_values has been set to the value of record_values - - foreach fid $record_form_ids { - if {$is_opt} { - set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS] - } else { - if {[dict get $F $fid argspace] eq "values"} { - set spec_merged [dict get $F $fid VALSPEC_DEFAULTS] - } else { - set spec_merged [dict get $F $fid LEADERSPEC_DEFAULTS] - } - } - - # -> argopt argval - foreach {spec specval} $argdef_values { - #literal-key switch - bytecompiled to jumpTable - switch -- $spec { - -form { - - } - -type { - #normalize here so we don't have to test during actual args parsing in main function - switch -- [tcl::string::tolower $specval] { - int - integer { - tcl::dict::set spec_merged -type int - } - bool - boolean { - tcl::dict::set spec_merged -type bool - } - char - character { - tcl::dict::set spec_merged -type char - } - dict - dictionary { - tcl::dict::set spec_merged -type dict - } - index - indexexpression { - tcl::dict::set spec_merged -type indexexpression - } - "" - none { - if {$is_opt} { - tcl::dict::set spec_merged -type none - 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. - } - } else { - #-solo only valid for flags - error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" - } - } - any - anything { - tcl::dict::set spec_merged -type any - } - ansi - ansistring { - tcl::dict::set spec_merged -type ansistring - } - any - string - globstring { - tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - } - literal { - #value is the name of the argument - if {$is_opt} { - error "punk::args::define - invalid -type 'literal' for flag argument '$argname' @id:$DEF_definition_id" - } - tcl::dict::set spec_merged -type literal - } - default { - #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW - tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - } - } - } - -default - -solo - -range - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo - - -minsize - -maxsize - -nocase - -optional - -multiple - - -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - - -regexprepass - -regexprefail - -regexprefailmsg - { - #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines - #review -solo 1 vs -type none ? conflicting values? - tcl::dict::set spec_merged $spec $specval - } - -ensembleparameter { - #review - only leaders? - tcl::dict::set spec_merged $spec $specval - } - -prefix { - #for flags/options - tcl::dict::set spec_merged $spec $specval - } - -validationtransform { - #string is dict only 8.7/9+ - if {[llength $specval] % 2} { - error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" - } - dict for {tk tv} $specval { - switch -- $tk { - -function - -type - -minsize - -maxsize - -range { - } - default { - set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? - error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" - } - } - } - - } - default { - if {[string match ref-* $spec]} { - #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) - #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. - if {![tcl::dict::exists $refs $specval]} { - puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" - } else { - set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" - if {$targetswitch eq "-*"} { - set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id - } else { - if {[tcl::dict::exists $refs $specval $targetswitch]} { - tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] - } else { - puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" - } - } - } - } else { - set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - -ensembleparameter\ - ] - error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" - } - } - } - } ;# end foreach {spec specval} argdef_values - - - if {$is_opt} { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - if {[tcl::dict::get $spec_merged -type] eq "none"} { - #JJJJ - dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname] - } - } else { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - tcl::dict::set F $fid ARG_INFO $argname $spec_merged - #review existence of -default overriding -optional - if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { - if {$is_opt} { - set temp_opt_required [dict get $F $fid OPT_REQUIRED] - lappend temp_opt_required $argname - dict set F $fid OPT_REQUIRED $temp_opt_required - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - set temp_leader_required [dict get $F $fid LEADER_REQUIRED] - lappend temp_leader_required $argname - dict set F $fid LEADER_REQUIRED $temp_leader_required - } else { - set temp_val_required [dict get $F $fid VAL_REQUIRED] - lappend temp_val_required $argname - dict set F $fid VAL_REQUIRED $temp_val_required - } - } - } - if {[tcl::dict::exists $spec_merged -default]} { - if {$is_opt} { - #tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] - tcl::dict::set F $fid OPT_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } else { - #tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] - tcl::dict::set F $fid VAL_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } - } - } - } ;# end foreach fid record_form_ids - - } ;# end foreach rec $records - - - #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { - # variable id_counter - # set DEF_definition_id "autoid_[incr id_counter]" - #} - - - #now cycle through ALL forms not just form_ids_active (record_form_ids) - dict for {fid formdata} $F { - # REVIEW - #no values specified - we can allow last leader to be multiple - foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { - error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" - } - } - - #todo - disallow any -multiple == true entries if any leaders have -multiple == true? - #(creates parsing ambiguity) - #ambiguity could be resolved if at least one required option/flag eg -- - #ambiguities could theoretically also be resolved with required literals or choices - or even based on argument type - #(overcomplex? todo see if any core/tcllib commands work like that) - - #only allow a single entry within VAL_NAMES to have -multiple == true - #example of command with non-trailing -multiple == true is core command: 'file copy ?-force? ?--? source ?source?... targetDir - set val_multiples 0 - foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { - if {$val_multiples > 0} { - error "bad setting -multiple true on argument spec for value '$valname' in command form:'$fid'. Only a single value argument specification can be marked with -multiple true @id:$DEF_definition_id" - } - incr val_multiples - } - } - - #todo - document that ambiguities in API are likely if both @leaders and @values used - #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) - - - dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata LEADERSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata OPTSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata VALSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - - - - - #todo - precalculate a set of 'arity' entries for each form - #We want a structure for the arg parser to get easy access and make a fast decision on which form applies - #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? - #1) after ms (1 1) - #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? - #3) after cancel id (2 2) - #4) after cancel script ?script...? (2 -1) - #5) after idle script ?script...? (1 -1) - #6) after info ?id? (1 2) - - #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) - - #in the above case we have no unique total_arity - #we would also want to consider values when selecting - #e.g given the invalid command "after cancel" - # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. - - - - set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands - #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use - #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form - #e.g commandline completion could show list of synopsis entries to select from - - set form_info [dict create] - dict for {fid fdict} $F { - dict set form_info $fid {} - dict for {optk optv} $fdict { - if {[string match -* $optk]} { - dict set form_info $fid $optk $optv - } - } - } - - set argdata_dict [tcl::dict::create\ - id $DEF_definition_id\ - cmd_info $cmd_info\ - doc_info $doc_info\ - package_info $package_info\ - seealso_info $seealso_info\ - id_info $id_info\ - FORMS $F\ - form_names [dict keys $F]\ - form_info $form_info\ - ] - - tcl::dict::set argdata_cache $cache_key $argdata_dict - if {$is_dynamic} { - #also cache resolved version - tcl::dict::set argdata_cache $optionspecs $argdata_dict - } - - #tcl::dict::set id_cache_rawdef $DEF_definition_id $args - #puts "xxx:$result" - return $argdata_dict - } - - #return raw definition list as created with 'define' - # - possibly with unresolved dynamic parts - proc raw_def {id} { - variable id_cache_rawdef - set realid [real_id $id] - if {![dict exists $id_cache_rawdef $realid]} { - return "" - } - return [tcl::dict::get $id_cache_rawdef $realid] - } - - - namespace eval argdoc { - variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @formdisplay @seealso @leaders @opts @values leaders opts values} - variable resolved_def_TYPE_CHOICEGROUPS { - directives {@id @package @cmd @ref @doc @formdisplay @seealso} - argumenttypes {leaders opts values} - remaining_defaults {@leaders @opts @values} - } - - lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { - @id -id ::punk::args::resolved_def - @cmd -name punk::args::resolved_def -help\ - "Resolves or retrieves the previously resolved definition and - uses the 'spec' form to build a response in definition format. - - Pulling argument definition data from another function is a form - of tight coupling to the other function that should be done with - care. - - Note that the directives @leaders @opts @values may appear multiple - times in a source definition - applying defaults for arguments that - follow. When retrieving these - there is only a single result for - each that represents the defaults after all have been applied. - When retrieving -types * each of these will be positioned before - the arguments of that type - but this doesn't mean there was a single - leading directive for this argument type in the source definition. - Each argument has already had its complete specification recorded in - its own result. - - When manually specifying -types, the order @leaders then @opts then - @values must be maintained - but if they are placed before their - corresponding arguments, they will not affect the retrieved arguments - as these arguments are already fully spec'd. The defaults from the - source can be removed by adding @leaders, @opts @values to the - -antiglobs list, but again - this won't affect the existing arguments. - Each argument can have members of its spec overridden using the - -override dictionary. - " - @leaders -min 0 -max 0 - @opts - -return -default text -choices {text dict} - -form -default 0 -help\ - "Ordinal index or name of command form" - - #no restriction on number of types/repetitions? - -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} - -antiglobs -default {} -type list -help\ - "Glob patterns for directive or argument/flags to - be suppressed" - -override -type dict -optional 1 -default "" -help\ - "dict of dicts. Key in outer dict is the name of a - directive or an argument. Inner dict is a map of - overrides/additions (- ...) for that line. - " - @values -min 1 -max -1 - id -type string -help\ - "identifer for a punk::args definition - This will usually be a fully-qualifed - path for a command name" - pattern -type string -optional 1 -default * -multiple 1 -help\ - "glob-style patterns for retrieving value or switch - definitions. - - If -type is * and pattern is * the entire definition including - directive lines will be returned in line form. - (directives are lines beginning with - @ e.g @id, @cmd etc) - - if -type is leaders,opts or values matches from that type - will be returned. - - if -type is another directive such as @id, @doc etc the - patterns are ignored. - - " - }]] - } - - - proc resolved_def {args} { - #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. - set opts [dict create\ - -return text\ - -types {}\ - -form 0\ - -antiglobs {}\ - -override {}\ - ] - if {[llength $args] < 1} { - #must have at least id - punk::args::parse $args withid ::punk::args::resolved_def - return - } - set patterns [list] - - #a definition id must not begin with "-" ??? review - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {$a in {-type -types}} { - incr i - dict set opts -types [lindex $args $i] - } elseif {[string match -* $a]} { - incr i - dict set opts $a [lindex $args $i] - } else { - set id [lindex $args $i] - set patterns [lrange $args $i+1 end] - break - } - if {$i == [llength $args]-1} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - if {![llength $patterns]} { - set patterns [list *] - } - dict for {k v} $opts { - switch -- $k { - -return - -form - -types - -antiglobs - -override {} - default { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - } - set typelist [dict get $opts -types] - if {[llength $typelist] == 0} { - set typelist {*} - } - foreach type $typelist { - if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - - - variable id_cache_rawdef - set realid [real_id $id] - if {$realid eq ""} { - return - } - - set deflist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] - - set opt_form [dict get $opts -form] - if {[string is integer -strict $opt_form]} { - set formname [lindex [dict get $specdict form_names] $opt_form] - } else { - set formname $opt_form - } - set opt_override [dict get $opts -override] - set opt_return [dict get $opts -return] - - #set arg_info [dict get $specdict ARG_INFO] - set arg_info [dict get $specdict FORMS $formname ARG_INFO] - set argtypes [dict create leaders leader opts option values value] - - set opt_antiglobs [dict get $opts -antiglobs] - set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] - set suppressed_directives [list] - set suppressed_args [list] - foreach ag $opt_antiglobs { - foreach d $directives { - if {[string match $ag $d]} { - lappend suppressed_directives $d - } - } - foreach argname [dict keys $arg_info] { - if {[string match $ag $argname]} { - lappend suppressed_args $argname - } - } - } - set suppressed_directives [lsort -unique $suppressed_directives] - set suppressed_args [lsort -unique $suppressed_args] - - set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] - - set globbed [list] - foreach pat $patterns { - set matches [dict keys $arg_info $pat] - lappend globbed {*}$matches - } - set globbed [lsort -unique $globbed] - #maintain order of original arg_info keys in globbed results - set ordered_globbed [list] - foreach a [dict keys $arg_info] { - if {$a ni $ordered_globbed && $a in $globbed} { - lappend ordered_globbed $a - } - } - set included_args [punk::args::system::punklib_ldiff $ordered_globbed $suppressed_args] - - set result "" - set resultdict [dict create] - foreach type $typelist { - switch -exact -- $type { - * { - if {"@id" in $included_directives} { - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - foreach directive {@package @cmd @doc @seealso} { - set dshort [string range $directive 1 end] - if {"$directive" in $included_directives} { - if {[dict exists $opt_override $directive]} { - append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict ${dshort}_info]" - dict set resultdict $directive [dict get $specdict ${dshort}_info] - } - } - } - - #todo @formdisplay - - - #output ordered by leader, option, value - foreach pseudodirective {leaders opts values} tp {leader option value} { - set directive "@$pseudodirective" - switch -- $directive { - @leaders {set defaults_key LEADERSPEC_DEFAULTS} - @opts {set defaults_key OPTSPEC_DEFAULTS} - @values {set defaults_key VALSPEC_DEFAULTS} - } - - if {"$directive" in $included_directives} { - if {[dict exists $opt_override "$directive"]} { - append result \n "$directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict FORMS $formname $defaults_key]" - dict set resultdict $directive [dict get $specdict FORMS $formname $defaults_key] - } - } - - if {$pseudodirective in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq $tp} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "$m $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - - } - @id { - if {"@id" in $included_directives} { - #only a single id record can exist - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - } - @package - @cmd - @doc - @seealso { - if {"$type" in $included_directives} { - set tp [string range $type 1 end] ;# @package -> package - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict ${tp}_info]" - dict set resultdict $type [dict get $specdict ${tp}_info] - } - } - #todo @formdisplay - } - @leaders - @opts - @values { - #these are the active defaults for further arguments - if {"$type" in $included_directives} { - switch -- $type { - @leaders {set defaults_key LEADERSPEC_DEFAULTS} - @opts {set defaults_key OPTSPEC_DEFAULTS} - @values {set defaults_key VALSPEC_DEFAULTS} - } - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS]" - dict set resultdict $type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] - } - } - } - leaders - opts - values { - #pseudo-directives - if {$type in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "$m $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - default { - } - } - if {$opt_return eq "text"} { - return $result - } else { - return $resultdict - } - } - } - - proc resolved_def_values {id {patternlist *}} { - variable id_cache_rawdef - set realid [real_id $id] - if {$realid ne ""} { - set speclist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [resolve {*}$speclist] - set arg_info [dict get $specdict ARG_INFO] - set valnames [dict get $specdict VAL_NAMES] - set result "" - if {$patternlist eq "*"} { - foreach v $valnames { - set def [dict get $arg_info $v] - set def [dict remove $def -ARGTYPE] - append result \n "$v $def" - } - return $result - } else { - foreach pat $patternlist { - set matches [dict keys $arg_info $pat] - set matches [lsearch -all -inline -glob $valnames $pat] - foreach m $matches { - set def [dict get $arg_info $m] - set def [dict remove $def -ARGTYPE] - append result \n "$m $def" - } - } - return $result - } - } - } - #proc resolved_def_leaders ?? - #proc resolved_def_opts ?? - - proc get_spec {id} { - set rdef [raw_def $id] - if {$rdef eq ""} { - return - } - return [resolve {*}$rdef] - #if {[id_exists $id]} { - # return [resolve {*}[raw_def $id]] - #} - } - proc is_dynamic {id} { - variable id_cache_rawdef - variable rawdef_cache - set deflist [raw_def $id] - if {[dict exists $rawdef_cache $deflist -dynamic]} { - return [dict get $rawdef_cache $deflist -dynamic] - } - return [rawdef_is_dynamic $deflist] - #@dynamic only has meaning as 1st element of a def in the deflist - } - - #@id must be within first 4 lines of a block - or assign auto - #review - @dynamic block where -id not explicitly set? - disallow? - proc rawdef_id {rawdef} { - set id "" - foreach d $rawdef { - foreach ln [lrange [split $d \n] 0 4] { - if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { - if {$firstword eq "@id"} { - if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { - set id [dict get $rest -id] - break - } - } - } - } - if {$id ne ""} { - break - } - } - if {$id eq "" || [string tolower $id] eq "auto"} { - variable id_counter - set id "autoid_[incr id_counter]" - } - #puts "==>id: $id" - return $id - } - #test the rawdef for @dynamic directive - proc rawdef_is_dynamic {rawdef} { - #temporary - old way - set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] - if {$flagged_dynamic} { - return true - } - foreach d $rawdef { - if {[regexp {\s*(\S+)} $d _match firstword]} { - if {$firstword eq "@dynamic"} { - return true - } - } - } - return false - } - - variable aliases - set aliases [dict create] - - lappend PUNKARGS [list { - @id -id ::punk::args::get_ids - @cmd -name punk::args::get_ids -help\ - "return list of ids for argument definitions" - @values -min 0 -max 1 - match -default * -help\ - "exact id or glob pattern for ids" - }] - proc get_ids {{match *}} { - variable id_cache_rawdef - variable aliases - return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] - } - - #we don't automatically test for (autodef)$id - only direct ids and aliases - proc id_exists {id} { - variable aliases - if {[tcl::dict::exists $aliases $id]} { - return 1 - } - variable id_cache_rawdef - tcl::dict::exists $id_cache_rawdef $id - } - proc set_alias {alias id} { - variable aliases - dict set aliases $alias $id - } - proc unset_alias {alias} { - variable aliases - dict unset aliases $alias - } - proc get_alias {alias} { - variable aliases - if {[dict exists $aliases $alias]} { - return [tcl::dict::get $aliases $alias] - } - } - - proc real_id {id} { - variable id_cache_rawdef - variable aliases - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } else { - set check_updates [list [namespace qualifiers $id]] - #puts stderr "---->real_id '$id' update_definitions $check_updates" - if {![llength [update_definitions $check_updates]]} { - #nothing new loaded - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } else { - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } - } - } - - proc status {} { - upvar ::punk::args::register::NAMESPACES registered - upvar ::punk::args::register::loaded_packages loaded_packages - upvar ::punk::args::register::loaded_info loaded_info - upvar ::punk::args::register::scanned_packages scanned_packages - upvar ::punk::args::register::scanned_info scanned_info - set result "" - # [format %-${w0}s $idtail] - set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] - append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n - set width_c2 [string length "Scanned_ids"] - set width_c3 [string length "Scantime_us"] - set width_c4 [string length "Loaded_defs"] - set width_c5 [string length "Loadtime_us"] - set count_unloaded 0 - set count_loaded 0 - foreach ns $registered { - if {$ns in $scanned_packages} { - set ids [dict get $scanned_info $ns idcount] - set scan_us [dict get $scanned_info $ns time] - } else { - set ids "" - set scan_us "" - } - if {$ns in $loaded_packages} { - incr count_loaded - set ldefs [dict get $loaded_info $ns defcount] - set load_us [dict get $loaded_info $ns time] - } else { - incr count_unloaded - set ldefs "" - set load_us "" - } - append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n - } - append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" - return $result - } - - #scanned_packages (list) - #namespace_docpackages (dict) - proc update_definitions {{nslist *}} { - #puts "----> update_definitions '$nslist'" - if {[set gposn [lsearch $nslist {}]] >= 0} { - lset nslist $gposn :: - } - upvar ::punk::args::register::NAMESPACES registered ;#list - upvar ::punk::args::register::loaded_packages loaded_packages ;#list - upvar ::punk::args::register::loaded_info loaded_info ;#dict - upvar ::punk::args::register::scanned_packages scanned_packages ;#list - upvar ::punk::args::register::scanned_info scanned_info ;#dict - upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict - - - #puts stderr "-->update_definitions '$nslist'" - #needs to run quickly - especially when no package namespaces to be scanned for argdefs - #e.g - gets called for each subcommand of an ensemble (could be many) - # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. - #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. - # -- --- --- --- --- --- - # common-case fast-path - - if {[llength $loaded_packages] == [llength $registered]} { - #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. - #assert - if all are registered - then all have been scanned - return {} - } - # -- --- --- --- --- --- - - set unscanned [punklib_ldiff $registered $scanned_packages] - if {[llength $unscanned]} { - foreach pkgns $unscanned { - set idcount 0 - set ts_start [clock microseconds] - if {[info exists ${pkgns}::PUNKARGS]} { - set seen_documentedns [list] ;#seen per pkgns - foreach definitionlist [set ${pkgns}::PUNKARGS] { - #namespace eval $evalns [list punk::args::define {*}$definitionlist] - set id [rawdef_id $definitionlist] - if {[string match autoid_* $id]} { - puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" - puts stderr "definition:\n" - foreach d $definitionlist { - set out "" - foreach ln [split $d \n] { - append out " " $ln \n - } - puts $out - } - continue - } - #todo - detect duplicate ids (last will silently win.. should be reported somewhere) - incr idcount - set documentedns [namespace qualifiers $id] - if {$documentedns eq ""} {set documentedns ::} - if {$documentedns ni $seen_documentedns} { - #don't add own ns as a key in namespace_docpackages - if {$documentedns ne $pkgns} { - dict lappend namespace_docpackages $documentedns $pkgns - } - lappend seen_documentedns $documentedns - } - } - } - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - dict set scanned_info $pkgns [dict create time $diff idcount $idcount] - #we count it as scanned even if PUNKARGS didn't exist - #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) - lappend scanned_packages $pkgns - } - } - - - - if {"*" in $nslist} { - set needed [punklib_ldiff $registered $loaded_packages] - } else { - set needed [list] - foreach pkgns $nslist { - if {![string match ::* $pkgns]} { - puts stderr "warning: update_definitions received unqualified ns: $pkgns" - set pkgns ::$pkgns - } - if {$pkgns in $registered && $pkgns ni $loaded_packages} { - lappend needed $pkgns - } - #argdoc sub namespace is a standard place to put defs that match the namespace below - #(generally the PUNKARGS in a namespace should apply to own ns) - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { - lappend needed $docns - } - } - if {[dict exists $namespace_docpackages $pkgns]} { - #this namespace has other argdef sources - foreach docns [dict get $namespace_docpackages $pkgns] { - if {$docns ni $loaded_packages} { - lappend needed $docns - } - } - } - } - } - - - - set newloaded [list] - foreach pkgns $needed { - #puts stderr "update_definitions Loading: $pkgns" - set ts_start [clock microseconds] - set def_count 0 - if {![catch { - if {[info exists ${pkgns}::PUNKARGS]} { - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - namespace eval ${pkgns}::argdoc { - set epath [namespace path] - set pkgns [namespace parent] - if {$pkgns ni $epath} { - namespace path [list {*}$epath $pkgns] ;#add to tail - } - - } - set evalns $docns - } else { - set evalns $pkgns - } - foreach definitionlist [set ${pkgns}::PUNKARGS] { - namespace eval $evalns [list punk::args::define {*}$definitionlist] - incr def_count - } - } - - #process list of 2-element lists - if {[info exists ${pkgns}::PUNKARGS_aliases]} { - foreach adef [set ${pkgns}::PUNKARGS_aliases] { - punk::args::set_alias {*}$adef - } - } - } errMsg]} { - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - lappend loaded_packages $pkgns - lappend newloaded $pkgns - dict set loaded_info $pkgns [dict create time $diff defcount $def_count] - } else { - puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" - } - } - return $newloaded - } - - #for use within get_dict only - #This mechanism gets less-than-useful results for oo methods - #e.g {$obj} - proc Get_caller {} { - #set call_level -3 ;#for get_dict call - set call_level -4 - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - #puts "-->$cmdinfo" - #puts "-->[tcl::info::frame -3]" - while {[string last \n $cmdinfo] >= 1} { - #looks like a script - haven't gone up far enough? - #(e.g patternpunk oo system: >punk . poses -invalidoption) - incr call_level -1 - if {[catch { - set nextup [tcl::info::frame $call_level] - } ]} { - break - } - set cmdinfo [tcl::dict::get $nextup cmd] - set caller [regexp -inline {\S+} $cmdinfo] - if {[interp alias {} $caller] ne ""} { - #puts "found alias for caller $caller to [interp alias {} $caller]" - #see if we can go further - incr call_level -1 - if {[catch { - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - } errM ]} { - puts "err: $errM" - break - } - } - } - set caller [regexp -inline {\S+} $cmdinfo] - if {$caller eq "namespace"} { - # review - message? - set cmdinfo "Get_caller (punk::args::get_dict?) called from namespace" - } - return $cmdinfo - } - - - # -------------------------------------- - #test of Get_caller - lappend PUNKARGS [list { - @id -id ::punk::args::test1 - @values -min 0 -max 0 - }] - proc test_get_dict {args} { - punk::args::get_dict [punk::args::raw_def ::punk::args::test1] $args - } - proc test_get_by_id {args} { - punk::args::get_by_id ::punk::args::test1 $args - } - #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. - proc test_callers {args} { - if {![llength $args]} { - puts "these test functions accept no arguments" - puts "Call with arg(s) to compare error output" - } - - if {[catch {test_get_dict {*}$args} errM]} { - puts $errM - } - puts "------------" - if {[catch {test_get_by_id {*}$args} errM]} { - puts $errM - } - return done - } - # -------------------------------------- - - set map "" - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::arg_error - @cmd -name punk::args::arg_error -help\ - "Generates a table (by default) of usage information for a command. - A trie system is used to create highlighted prefixes for command - switches and for subcommands or argument/switch values that accept - a defined set of choices. These prefixes match the mechanism used - to validate arguments (based on tcl::prefix::match). - - This function is called during the argument parsing process - (if the definition is not only being used for documentation) - It is also called by punk::args::usage which is in turn - called by the punk::ns introspection facilities which creates - on the fly definitions for some commands such as ensembles and - oo objects where a manually defined one isn't present. - " - @leaders -min 2 -max 2 - msg -type string -help\ - "Error message to display immediately prior to usage table. - May be empty string to just display usage. - " - spec_dict -type dict -help\ - "Dictionary of argument specifications. - This is the internal format parsed from - the textual definition. It contains the data - organised/optimised to allow the final arg - parser/validator to make decisions. - " - @opts - -badarg -type string -help\ - "name of an argument to highlight" - -parsedargs -type dict -help\ - "Result of successful punk::pargs::parse - (currently only looks at 'received')" - -aserror -type boolean -help\ - "If true, the usage table is raised as an error message, - otherwise it is returned as a value." - -return -choices {string table tableobject} -choicelabels { - string "no table layout" - tableobject "table object cmd" - table "full table layout" - } - -scheme -default error -choices {nocolour info error} - -form -default 0 -help\ - "Ordinal index or name of command form" - }] ] - - #basic recursion blocker - variable arg_error_isrunning 0 - proc arg_error {msg spec_dict args} { - #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. - #accept an option here so that we can still use full output for usage requests. - #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args - #Development/experimentation may be done with full table-based error reporting - but for production release it - #may be desirable to reduce overhead on catches. - #consider per-namespace or namespace-tree configurability. - #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due - #to resource availability etc - so the slower error generation time may not always be a problem. - #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling - #code which has no use for the enhanced error info. - #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. - #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system - #todo - #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error - #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) - - #todo - document unnamed leaders and unnamed values where -min and/or -max specified - #e.g punk::args::parse {} withdef {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} - #only |?-x?|string|... is shown in the output table. - #should be something like: - # |arg | - # |?-x? | - # |arg | - # |?arg...?| - # Where/how to specify counts? - #also.. - # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? - # - - - if {[catch {package require punk::ansi}]} { - proc punk::args::a {args} {} - proc punk::args::a+ {args} {} - } else { - namespace eval ::punk::args { - namespace import ::punk::ansi::a ::punk::ansi::a+ - } - } - #limit colours to standard 16 so that themes can apply to help output - variable arg_error_isrunning - if {$arg_error_isrunning} { - error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" - } - - if {[llength $args] %2 != 0} { - error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" - } - - set arg_error_isrunning 1 - - set badarg "" - set parsedargs [dict create] ;#dict with keys: leaders,opts,values,received,solos,multis (as from punk::args::parse) - set goodargs [list] - set returntype table ;#table as string - set as_error 1 ;#usual case is to raise an error - set scheme error - set form 0 - dict for {k v} $args { - set fullk [tcl::prefix::match -error "" {-badarg -parsedargs -aserror -return -scheme -form} $k] - switch -- $fullk { - -badarg { - set badarg $v - } - -parsedargs { - #todo? - dict for {set setinfo} $v { - switch -- $set { - received { - foreach {r rpos} $setinfo { - if {$r ni $goodargs} { - lappend goodargs $r - } - } - } - } - } - set parsedargs $v - } - -aserror { - if {![string is boolean -strict $v]} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" - } - set as_error $v - } - -scheme { - set scheme $v - } - -return { - if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" - } - set returntype $v - } - -form { - set form $v - } - default { - set arg_error_isrunning 0 - error "arg_error invalid option $k. Known_options: -badarg -parsedargs -aserror -scheme -return -form" - } - } - } - #todo - scheme - use config and iterm toml definitions etc - switch -- $scheme { - "" - -nocolor - -nocolour { - set scheme nocolour - } - info - error {} - default { - set scheme na - } - } - set formnames [dict get $spec_dict form_names] - if {[string is integer -strict $form]} { - if {$form < 0 || $form > [llength $formnames]-1} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" - } - set selected_forms [list [lindex $formnames $form]] - } else { - if {$form eq "*"} { - set selected_forms $formnames - } else { - if {$form in $formnames} { - set selected_forms [list $form] - } else { - set arg_error_isrunning 0 - error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" - } - } - } - - - #hack some basics for now. - #for coloured schemes - use bold as well as brightcolour in case colour off. - array set CLR {} - set CLR(errormsg) [a+ brightred] - set CLR(title) "" - set CLR(check) [a+ brightgreen] - set CLR(solo) [a+ brightcyan] - set CLR(choiceprefix) [a+ underline] - set CLR(badarg) [a+ brightred] - set CLR(goodarg) [a+ green strike] - set CLR(goodchoice) [a+ reverse] - set CLR(linebase_header) [a+ white] - set CLR(cmdname) [a+ brightwhite] - set CLR(groupname) [a+ bold] - set CLR(ansiborder) [a+ bold] - set CLR(ansibase_header) [a+ bold] - set CLR(ansibase_body) [a+ white] - - switch -- $scheme { - nocolour { - set CLR(errormsg) [a+ bold] - set CLR(title) [a+ bold] - set CLR(check) "" - set CLR(solo) "" - set CLR(badarg) [a+ reverse] ;#? experiment - set CLR(goodarg) [a+ strike] - set CLR(cmdname) [a+ bold] - set CLR(linebase_header) "" - set CLR(linebase) "" - set CLR(ansibase_body) "" - } - info { - set CLR(errormsg) [a+ brightred bold] - set CLR(title) [a+ brightyellow bold] - set CLR(check) [a+ brightgreen bold] - set CLR(choiceprefix) [a+ brightgreen bold] - set CLR(groupname) [a+ cyan bold] - set CLR(ansiborder) [a+ brightcyan bold] - set CLR(ansibase_header) [a+ cyan] - set CLR(ansibase_body) [a+ white] - } - error { - set CLR(errormsg) [a+ brightred bold] - set CLR(title) [a+ brightcyan bold] - set CLR(check) [a+ brightgreen bold] - set CLR(choiceprefix) [a+ brightgreen bold] - set CLR(groupname) [a+ cyan bold] - set CLR(ansiborder) [a+ brightyellow bold] - set CLR(ansibase_header) [a+ yellow] - set CLR(ansibase_body) [a+ white] - } - na { - } - } - - - #set RST [a] - set RST "\x1b\[m" - set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. - - #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error - #e.g list_as_table - - # use basic colours here to support terminals without extended colours - #todo - add checks column (e.g -minsize -maxsize) - set errmsg $msg - if {![catch {package require textblock}]} { - set has_textblock 1 - } else { - set has_textblock 0 - #couldn't load textblock package - #just return the original errmsg without formatting - } - set use_table 0 - if {$has_textblock && $returntype in {table tableobject}} { - set use_table 1 - } - set errlines [list] ;#for non-textblock output - if {[catch { - if {$use_table} { - append errmsg \n - } else { - if {($returntype in {table tableobject}) && !$has_textblock} { - append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n - } else { - append errmsg \n - } - } - set cmdname [Dict_getdef $spec_dict cmd_info -name ""] - set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] - - set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] - set docurl [Dict_getdef $spec_dict doc_info -url ""] - - #set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] - #set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] - #if {"$argdisplay_header$argdisplay_body" eq ""} { - # set is_custom_argdisplay 0 - #} else { - # set is_custom_argdisplay 1 - #} - - #temp - TODO - set argdisplay_header "" - set argdisplay_body "" - set is_custom_argdisplay 0 - - - set blank_header_col [list] - if {$cmdname ne ""} { - lappend blank_header_col "" - set cmdname_display $CLR(cmdname)$cmdname$RST - } else { - set cmdname_display "" - } - if {$cmdhelp ne ""} { - lappend blank_header_col "" - #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] - set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] - } else { - set cmdhelp_display "" - } - if {$docurl ne ""} { - lappend blank_header_col "" - set docurl_display [a+ white]$docurl$RST - } else { - set docurl_display "" - } - #synopsis - set synopsis "" - set form_info [dict get $spec_dict form_info] - dict for {fid finfo} $form_info { - set form_synopsis [Dict_getdef $finfo -synopsis ""] - if {$form_synopsis eq ""} { - #todo - set form_synopsis [punk::args::synopsis -form $fid [dict get $spec_dict id]] - if {[string length $form_synopsis] > 90} { - set form_synopsis [punk::args::synopsis -return summary -form $fid [dict get $spec_dict id]] - } - if {[string match (autodef)* $form_synopsis]} { - set form_synopsis [string range $form_synopsis 9 end] - } - } - if {$fid in $selected_forms} { - set form_synopsis [punk::ansi::a+ underline]$form_synopsis[punk::ansi::a+ nounderline] - } - append synopsis $form_synopsis \n - } - if {$synopsis ne ""} { - set synopsis [string trimright $synopsis \n] - lappend blank_header_col "" - } - - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - if {$use_table} { - set t [textblock::class::table new "$CLR(title)Usage$RST"] - $t add_column -headers $blank_header_col -minwidth 3 - $t add_column -headers $blank_header_col - - if {!$is_custom_argdisplay} { - lappend blank_header_col "" - #spanned columns in default argdisplay area - $t add_column -headers $blank_header_col ;#Default - $t add_column -headers $blank_header_col ;#Multi - $t add_column -headers $blank_header_col ;#Help - set arg_colspans {1 4 0 0 0} - } else { - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - set arg_colspans {1 1} - } - } - set h 0 - if {$cmdname ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] - } else { - lappend errlines "COMMAND: $cmdname_display" - } - incr h - } - if {$cmdhelp ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] - } else { - lappend errlines "Description: $cmdhelp_display" - } - incr h - } - if {$docurl ne ""} { - if {![catch {package require punk::ansi}]} { - set docurl [punk::ansi::hyperlink $docurl] - } - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] - } else { - lappend errlines "$docname $docurl_display" - } - incr h - } - if {$synopsis ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Synopsis: [punk::ansi::ansiwrap brightwhite $synopsis]] - } else { - #todo - lappend errlines "Synopsis:\n$synopsis" - } - incr h - } - - - if {$use_table} { - if {$is_custom_argdisplay} { - if {$argdisplay_header ne ""} { - $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] - } - } else { - $t configure_header $h -values {Arg Type Default Multi Help} - } - } else { - lappend errlines " --ARGUMENTS-- " - } - - if {$is_custom_argdisplay} { - if {$use_table} { - #using overall container table - #header already added - #TODO - review textblock::table features - #we can't currently span columns within the table body. - #This feature could allow hidden data columns (and sort on hidden col?) - #potentially require coordination with header colspans? - $t add_row [list "" $argdisplay_body] - } else { - if {$argdisplay_header ne ""} { - lappend errlines $argdisplay_header - } - lappend errlines {*}$argdisplay_body - } - } else { - - #set A_DEFAULT [a+ brightwhite Brightgreen] - set A_DEFAULT "" - set A_BADARG $CLR(badarg) - set A_GOODARG $CLR(goodarg) - set A_GOODCHOICE $CLR(goodchoice) - set greencheck $CLR(check)\u2713$RST ;#green tick - set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply - if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { - #A_PREFIX can resolve to empty string if colour off - #we then want to display underline instead - set A_PREFIX [a+ underline] - set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space - } else { - set A_PREFIXEND $RST - } - - #TODO - foreach fid - set fid [lindex $selected_forms 0] - set form_dict [dict get $spec_dict FORMS $fid] - - set opt_names [list] - set opt_names_display [list] - if {[llength [dict get $form_dict OPT_NAMES]]} { - if {![catch {package require punk::trie}]} { - set trie [punk::trie::trieclass new {*}[dict get $form_dict OPT_NAMES]] - set idents [dict get [$trie shortest_idents ""] scanned] - #todo - check opt_prefixdeny - - $trie destroy - foreach c [dict get $form_dict OPT_NAMES] { - set arginfo [dict get $form_dict ARG_INFO $c] - if {[dict get $arginfo -prefix]} { - set id [dict get $idents $c] - #REVIEW - if {$id eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $id] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail - } else { - lappend opt_names_display $c - } - #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] - lappend opt_names $c - } - } else { - set opt_names [dict get $form_dict OPT_NAMES] - set opt_names_display $opt_names - } - } - set leading_val_names [dict get $form_dict LEADER_NAMES] - set trailing_val_names [dict get $form_dict VAL_NAMES] - - #dict for {argname info} [tcl::dict::get $form_dict arg_info] { - # if {![string match -* $argname]} { - # lappend leading_val_names [lpop trailing_val_names 0] - # } else { - # break - # } - #} - #if {![llength $leading_val_names] && ![llength $opt_names]} { - # #all vals were actually trailing - no opts - # set trailing_val_names $leading_val_names - # set leading_val_names {} - #} - set leading_val_names_display $leading_val_names - set trailing_val_names_display $trailing_val_names - #puts "--> parsedargs: $parsedargs" - set parsed_leaders [Dict_getdef $parsedargs leaders {}] - set parsed_opts [Dict_getdef $parsedargs opts {}] - set parsed_values [Dict_getdef $parsedargs values {}] - - #display options first then values - foreach argumentset [list [list $leading_val_names_display $leading_val_names $parsed_leaders] [list $opt_names_display $opt_names $parsed_opts] [list $trailing_val_names_display $trailing_val_names $parsed_values]] { - lassign $argumentset argnames_display argnames parsedvalues - - foreach argshow $argnames_display arg $argnames { - set arginfo [dict get $form_dict ARG_INFO $arg] - if {[dict exists $arginfo -default]} { - set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" - } else { - set default "" - } - set help [Dict_getdef $arginfo -help ""] - set allchoices_originalcase [list] - set choices [Dict_getdef $arginfo -choices {}] - set choicegroups [Dict_getdef $arginfo -choicegroups {}] - set choicemultiple [dict get $arginfo -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] - set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] - if {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - set is_multiple 1 - } else { - set multiple "" - set is_multiple 0 - } - if {[dict exists $choicegroups ""]} { - dict lappend choicegroups "" {*}$choices - } else { - set choicegroups [dict merge [dict create "" $choices] $choicegroups] - } - dict for {groupname clist} $choicegroups { - lappend allchoices_originalcase {*}$clist - } - set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] - - if {$has_choices} { - if {$help ne ""} {append help \n} - if {[dict get $arginfo -nocase]} { - set casemsg " (case insensitive)" - set allchoices_test [string tolower $allchoices_originalcase] - } else { - set casemsg " (case sensitive)" - set allchoices_test $allchoices_originalcase - } - if {[dict get $arginfo -choiceprefix]} { - set prefixmsg " (choice prefix allowed)" - } else { - set prefixmsg "" - } - set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] - set choiceinfodict [Dict_getdef $arginfo -choiceinfo {}] - set formattedchoices [dict create] ;#use dict rather than array to preserve order - append help " Choices$prefixmsg$casemsg" - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - if {$choicemultiple_max == -1} { - append help \n " The value can be a list of $choicemultiple_min or more of these choices" - } else { - if {$choicemultiple_min eq $choicemultiple_max} { - append help \n " The value must be a list of $choicemultiple_min of these choices" - } else { - append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" - } - } - } - if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c [join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } else { - #set formattedchoices $choicegroups - #set formattedchoices [dict get $arginfo -choices] - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c [join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } - } else { - if {[catch { - set trie [punk::trie::trieclass new {*}$allchoices_test] - set idents [dict get [$trie shortest_idents ""] scanned] - if {[dict get $arginfo -nocase]} { - #idents were calculated on lcase - remap keys in idents to original casing - set actual_idents $idents - foreach ch $allchoices_originalcase { - if {![dict exists $idents $ch]} { - #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting - #The actual testing is done in get_dict - dict set actual_idents $ch [dict get $idents [string tolower $ch]] - } - } - set idents $actual_idents - #puts "-----" - #puts "idents $idents" - } - - $trie destroy - dict for {groupname clist} $choicegroups { - foreach c $clist { - if {$c in $choiceprefixdenylist} { - set shortestid $c - } else { - set shortestid [dict get $idents $c] - } - if {$shortestid eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $shortestid] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set mk " [join $markers {}]" - } else { - set mk "" - } - set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]$mk" - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - #puts "-- parsed:$parsedvalues arg:$arg c:$c" - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } errM]} { - #this failure can happen if -nocase is true and there are ambiguous entries - #e.g -nocase 1 -choices {x X} - puts stderr "prefix marking failed\n$errM" - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c [join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } else { - #set formattedchoices $choicegroups - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c[join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } - - } - } - set choicetable_objects [list] - set choicetable_footers [dict create] - dict for {groupname formatted} $formattedchoices { - set numcols $choicecolumns ;#todo - dynamic? - if {[llength $formatted] < $numcols} { - #don't show blank cells if single line of results - set numcols [llength $formatted] - } - if {$numcols > 0} { - if {$use_table} { - #risk of recursing - #TODO -title directly in list_as_table - set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] - lappend choicetable_objects $choicetableobj - $choicetableobj configure -title $CLR(groupname)$groupname - #append help \n[textblock::join -- " " [$choicetableobj print]] - } else { - if {$groupname ne ""} { - append help \n \n "$CLR(groupname)Group: $groupname$RST" - } else { - append help \n - } - append help \n [join $formatted \n] - } - } else { - #we were given an empty set of choices. - #probably an error in the definition - but could happen if dynamically generated. - #(e.g ensemble where unknown mechanism is used for subcommands?) - #better to just display that there were none rather than totally break the usage output. - if {$usetable} { - #these will be displayed after all table entries - if {$groupname eq ""} { - dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" - } else { - dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" - } - } else { - if {$groupname eq ""} { - append help \n " " $CLR(errormsg)(no choices defined)$RST - } else { - append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST - } - } - } - } - set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width - foreach obj $choicetable_objects { - dict lappend twidths_by_colcount [$obj column_count] [$obj width] - } - foreach obj $choicetable_objects { - set cols [$obj column_count] - set widths [dict get $twidths_by_colcount $cols] - set max [tcl::mathfunc::max {*}$widths] - $obj configure -minwidth $max ;#expand smaller ones - set i 0 - while {$i < $cols} { - #keep text aligned left on expanded tables - $obj configure_column $i -blockalign left - incr i - } - - append help \n[textblock::join -- " " [$obj print]] - #set ansititle [dict get [$obj configure -title] value] - $obj destroy - } - if {[dict size $choicetable_footers]} { - foreach groupname [dict keys $formattedchoices] { - if {[dict exists $choicetable_footers $groupname]} { - append help \n [dict get $choicetable_footers $groupname] - } - } - } - - #review. use -type to restrict additional choices - may be different to values in the -choices - if {![dict get $arginfo -choicerestricted]} { - #when -choicemultiple - the -type refers to each selection - if {[dict get $arginfo -type] eq "string"} { - append help "\n (values not in defined choices are allowed)" - } else { - append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" - } - } - } - if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { - if {$is_multiple} { - set argshow "?${argshow}...?" - } else { - set argshow "?${argshow}?" - } - } else { - if {$is_multiple} { - set argshow "${argshow}..." - } - } - set typeshow [dict get $arginfo -type] - if {$typeshow eq "none"} { - set typeshow "$typeshow $soloflag" - } - if {[dict exists $arginfo -minsize]} { - append typeshow \n "-minsize [dict get $arginfo -minsize]" - } - if {[dict exists $arginfo -maxsize]} { - append typeshow \n "-maxsize [dict get $arginfo -maxsize]" - } - if {[dict exists $arginfo -range]} { - append typeshow \n "-range [dict get $arginfo -range]" - } - - if {$use_table} { - $t add_row [list $argshow $typeshow $default $multiple $help] - if {$arg eq $badarg} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG - } elseif {$arg in $goodargs} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $A_GOODARG - } - } else { - #review - formatting will be all over the shop due to newlines in typesshow, help - set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" - if {$arg eq $badarg} { - set arghelp [punk::ansi::ansiwrap -rawansi $A_BADARG $arghelp] - } elseif {$arg in $goodargs} { - set arghelp [punk::ansi::ansiwrap -rawansi $A_GOODARG $arghelp] - } - foreach ln [split $help \n] { - append arghelp " $ln" \n - } - lappend errlines $arghelp - } - } - } - } ;#end is_custom_argdisplay - - if {$use_table} { - $t configure -show_hseps 0\ - -show_header 1\ - -ansibase_body $CLR(ansibase_body)\ - -ansibase_header $CLR(ansibase_header)\ - -ansiborder_header $CLR(ansiborder)\ - -ansiborder_body $CLR(ansiborder) - - $t configure -maxwidth 80 ;#review - if {$returntype ne "tableobject"} { - append errmsg [$t print] - #returntype of table means just the text of the table - $t destroy - } - } else { - append errmsg [join $errlines \n] - } - } errM]} { - catch {$t destroy} - append errmsg \n - append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n - append errmsg "$errM" \n - append errmsg "$::errorInfo" - - } - set arg_error_isrunning 0 - if {$use_table} { - #assert returntype is one of table, tableobject - set result $errmsg ;#default if for some reason table couldn't be used - if {$returntype eq "tableobject"} { - if {[info object isa object $t]} { - set result $t - } - } - } else { - set result $errmsg - } - if {$as_error} { - #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. - #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) - uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] - } else { - return $result - } - } - - - lappend PUNKARGS [list { - @dynamic - @id -id ::punk::args::usage - @cmd -name punk::args::usage -help\ - "Return usage information for a command identified by an id. - - This will only work for commands where a punk::args definition exists - for the command and an id has been defined for it. The id for custom - help for a command should match the fully qualified name of the command. - - Many commands (such as ensembles and oo objects) may have argument - documentation generated dynamically and may not yet have an id. - IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. - - Generally punk::ns::arginfo (aliased as i in the punk shell) should - be used in preference - as it will search for a documentation - mechanism and call punk::args::usage as necessary. - " - -return -default table -choices {string table tableobject} - }\ - {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}}\ - {${[punk::args::resolved_def -types opts ::punk::args::resolved_def -form]}}\ - { - - @values -min 0 -max 1 - id -help\ - "Exact id. - Will usually match the command name" - }] - proc usage {args} { - #lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received - lassign [dict values [punk::args::parse $args withid ::punk::args::usage]] leaders opts values received - set id [dict get $values id] - set real_id [real_id $id] - if {$real_id eq ""} { - error "punk::args::usage - no such id: $id" - } - #-scheme punk_info ?? - arg_error "" [punk::args::get_spec $real_id] {*}$opts -aserror 0 - } - - lappend PUNKARGS [list { - @id -id ::punk::args::get_by_id - @cmd -name punk::args::get_by_id - @values -min 1 - id - arglist -type list -help\ - "list containing arguments to be parsed as per the - argument specification identified by the supplied id." - }] - - - #deprecate? - proc get_by_id {id arglist} { - set definitionlist [punk::args::raw_def $id] - if {[llength $definitionlist] == 0} { - error "punk::args::get_by_id - no such id: $id" - } - #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] - tailcall ::punk::args::get_dict $definitionlist $arglist - } - - #consider - - #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) - #parse ?-flag val?... -- $arglist withid $id - #parse ?-flag val?... -- $arglist withdef $def ?$def?... - - #an experiment.. ideally we'd like arglist at the end? - #parse_withid ?-flag val?.. $id $arglist - #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? - #no possible equivalent for parse_withdef ??? - - lappend PUNKARGS [list { - @id -id ::punk::args::parse - @cmd -name punk::args::parse -help\ - "parse and validate command arguments based on a definition. - - In the 'withid' form the definition is a pre-existing record that has been - created with ::punk::args::define, or indirectly by adding a definition to - the PUNKARGS variable in a namespace which is then registered in - punk::args::register::NAMESPACES, or by a previous call to punk::parse - using 'withdef' and a definition block containing an @id -id directive. - - In the 'withdef' form - the definition is created on the first call and - cached thereafter, if the id didn't already exist. - - form1: parse $arglist ?-flag val?... withid $id - form2: parse $arglist ?-flag val?... withdef $def ?$def? - see punk::args::define - - Returns a dict of information regarding the parsed arguments - example of basic usage for single option only: - punk::args::define { - @id -id ::myns::myfunc - @cmd -name myns::myfunc - @leaders -min 0 -max 0 - @opts - -configfile -type existingfile - #type none makes it a solo flag - -verbose -type none - @values -min 0 -max 0 - } - proc myfunc {args} { - set argd [punk::args::parse $args withid ::myns::myfunc] - lassign [dict values $argd] leaders opts values received solos - if {[dict exists $received] -configfile} { - puts \"have option for existing file [dict get $opts -configfile]\" - } - } - The leaders, opts, values keys in the parse result dict are proper dicts. - The received key is dict-like but can have repeated keys for arguments than can - accept multiples. The value for each received element is the ordinal position. - The solos key refers to a list of solo flags received (those specified with - -type none). This is generally only useful to assist in passing arguments on - to another procedure which also requires solos, because the opts dict contains - solo flags with a 1 value or a list of 1's if it was a solo with -multiple true - specified. - " - @form -form {withid withdef} - @leaders -min 1 -max 1 - arglist -type list -optional 0 -help\ - "Arguments to parse - supplied as a single list" - - @opts - -form -type list -default * -help\ - "Restrict parsing to the set of forms listed. - Forms are the orthogonal sets of arguments a - command can take - usually described in 'synopsis' - entries." - #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance - #todo - configurable per interp/namespace - -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} - - @values -min 2 - - @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" - @values -max 2 - withid -type literal -help\ - "The literal value 'withid'" - id -type string -help\ - "id of punk::args definition for a command" - - - @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" - withdef -type literal -help\ - "The literal value 'withdef'" - - #todo - make -dynamic obsolete - use @dynamic directive instead - def -type string -multiple 1 -optional 0 -help\ - "Each remaining argument is a block of text - defining argument definitions. - As a special case, -dynamic may be - specified as the 1st 2 arguments. These are - treated as an indicator to punk::args about - how to process the definition." - - }] - proc parse {args} { - set tailtype "" ;#withid|withdef - if {[llength $args] < 3} { - #error "punk::args::parse - invalid call. < 3 args" - punk::args::parse $args withid ::punk::args::parse - } - set opts_and_vals $args - set parseargs [lpop opts_and_vals 0] - - set opts [list] - set values [list] - for {set i 0} {$i < [llength $opts_and_vals]} {incr i} { - if {[string match -* [lindex $opts_and_vals $i]]} { - if {[catch { - lappend opts [lpop opts_and_vals 0] [lpop opts_and_vals 0] - }]} { - punk::args::parse $args withid ::punk::args::parse - } - incr i -1 - #lappend opts $a [lindex $opts_and_vals $i] - } else { - break - } - } - #set values [lrange $opts_and_vals $i end] - set values $opts_and_vals - #puts "---values: $values" - set tailtype [lindex $values 0] - set tailargs [lrange $values 1 end] - - - #set split [lsearch -exact $tailargs withid] - #if {$split < 0} { - # set split [lsearch -exact $tailargs withdef] - # if {$split < 0} { - # #punk::args::usage arg_error? - # #error "punk::args::parse - invalid call. keyword withid|withdef required" - # punk::args::parse $args withid ::punk::args::parse - # } else { - # set tailtype withdef - #} - #} else { - # set tailtype withid - #} - #set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. - - - #if {[llength $opts] % 2} { - #error "punk::args::parse Even number of -flag val pairs required after arglist" - #} - - #Default the -errorstyle to enhanced - # (slowest on unhappy path - but probably clearest for playing with new APIs interactively) - # - application devs should distribute a config file with an errorstyle override if desired. - # - devs who prefer a different default for interactive use should create a config for it. (todo) - set defaultopts [dict create\ - -form {*}\ - -errorstyle enhanced\ - ] - - #todo - load override_errorstyle from configuration - #dict set defaultopts -errorstyle $ - #puts "def: $defaultopts opts: $opts" - set opts [dict merge $defaultopts $opts] - dict for {k v} $opts { - switch -- $k { - -form - -errorstyle { - } - default { - #punk::args::usage $args withid ::punk::args::parse ?? - #error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" - punk::args::parse $args withid ::punk::args::parse - } - } - } - switch -- $tailtype { - withid { - if {[llength $tailargs] != 1} { - #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - punk::args::parse $args withid ::punk::args::parse - } - set id [lindex $tailargs 0] - #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" - set deflist [raw_def $id] - if {[llength $deflist] == 0} { - error "punk::args::parse - no such id: $id" - } - } - withdef { - set deflist $tailargs - if {[llength $deflist] < 1} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" - } - default { - error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" - } - } - try { - set result [punk::args::get_dict $deflist $parseargs -form [dict get $opts -form]] - } trap {PUNKARGS VALIDATION} {msg erroropts} { - set opt_errorstyle [dict get $opts -errorstyle] - - #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - - - set ecode [dict get $erroropts -errorcode] - #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... - set msg [string map [list %caller% [Get_caller]] $msg] - switch -- $opt_errorstyle { - minimal { - return -options [list -code error -errorcode $ecode] $msg - } - basic { - #No table layout - unix manpage style - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg -form [dict get $opts -form]] - } - return -options [list -code error -errorcode $ecode] $msg - } - standard { - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] - } - return -options [list -code error -errorcode $ecode] $msg - } - enhanced { - set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below) - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - set ecode_summary [lrange $ecode 0 2] - if {$badarg ne ""} { - lappend ecode_summary -badarg $badarg - } - catch {package require punk::lib} - if {[package provide punk::lib] ne ""} { - append msg \n [punk::lib::showdict -roottype list $estack */*] - } - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] - append msg \n "::errorCode summary: $ecode_summary" - return -options [list -code error -errorcode $ecode] $msg - } else { - #why? todo? - append msg \n "(enhanced error information unavailable)" - append msg \n "::errorCode summary: $ecode_summary" - return -options [list -code error -errorcode $ecode] $msg - } - } - debug { - puts stderr "errorstyle debug not implemented" - return -options [list -code error -errorcode $ecode] $msg - } - default { - puts stderr "errorstyle $opt_errorstyle not recognised: expected one of minimal basic standard enhanced debug" - return -options [list -code error -errorcode $ecode] $msg - } - } - } trap {PUNKARGS} {msg erropts} { - append msg \n "Unexpected PUNKARGS error" - return -options [list -code error -errorcode $ecode] $msg - } trap {} {msg erroropts} { - #review - #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. - #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. - throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] - } - return $result - } - proc parseXXX {args} { - #no solo flags allowed for parse function itself. (ok for arglist being parsed) - set opts [dict create] ;#repeated flags will override earlier. That's ok here. - set arglist {} - set got_arglist 0 - set tailtype "" ;#withid|withdef - set id "" - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {[string match -* $a]} { - dict set opts $a [lindex $args $i+1] - incr i - } else { - set arglist $a - set got_arglist 1 - set tailtype [lindex $args $i+1] - if {$tailtype eq "withid"} { - if {[llength $args] != $i+3} { - error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - } - set id [lindex $args $i+2] - break - } elseif {$tailtype eq "withdef"} { - if {[llength $args] < $i+3} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - set deflist [lrange $args $i+2 end] - break - } else { - error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" - } - } - } - if {!$got_arglist} { - error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." - } - #assert tailtype eq withid|withdef - if {$tailtype eq "withid"} { - #assert $id was provided - return "parse [llength $arglist] args withid $id, options:$opts" - } else { - #assert llength deflist >=1 - return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" - } - #TODO - } - - #todo? - a version of get_dict that directly supports punk::lib::tstr templating - #rename get_dict - # - - #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 get_dict {deflist rawargs args} { - #see arg_error regarding considerations around unhappy-path performance - - if {[llength $args] % 2 != 0} { - error "punk::args::get_dict args must be a dict of option value pairs" - } - set defaults [dict create\ - -form *\ - ] - set opts [dict merge $defaults $args] - dict for {k v} $opts { - switch -- $k { - -form {} - default { - error "punk::args::get_dict Unexpected option '$k' Known options -form" - } - } - } - - - #*** !doctools - #[call [fun get_dict] [arg deflist] [arg rawargs] [arg args]] - #[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 values - #[para]ARGUMENTS: - #[list_begin arguments] - #[arg_def list-of-multiline-string deflist] - #[para] These are blocks 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 defining a flag 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 - #[para]Each optionspec line defining a positional argument is of the form: - #[para]argumentname -key val -ky2 val2... - #[para]where the valid keys for each option specification are: -default -type -range -choices - #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value - #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. - #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. - #[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, - #but it could be a manually constructed list of values made for example from positional args defined in the proc. - #[list_end] - #[para] - - #consider line-processing example below for which we need info complete to determine record boundaries - #punk::args::get_dict [list { - # @opts - # -opt1 -default {} - # -opt2 -default { - # etc - # } - # @values -multiple 1 - #}] $args - - - - - #rawargs: args values to be parsed - #we take a definition list rather than resolved argspecs - because the definition could be dynamic - - #if definition has been seen before, - #define will either return a permanently cached argspecs (-dynamic 0) - or - # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. - set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]] - - # ----------------------------------------------- - # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) - tcl::dict::with argspecs {} ;#turn keys into vars - #e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info,id_info,form_names - # ----------------------------------------------- - set opt_form [dict get $opts -form] - if {$opt_form eq "*"} { - set selected_forms $form_names - } elseif {[string is integer -strict $opt_form]} { - if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { - error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set selected_forms [list [lindex $form_names $opt_form]] - } else { - if {$opt_form ni $form_names} { - error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set selected_forms [list $opt_form] - } - - - #puts "-arg_info->$arg_info" - set flagsreceived [list] ;#for checking if required flags satisfied - set solosreceived [list] - set multisreceived [list] - #secondary purpose: - #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 ? - - # -- --- --- --- - # Handle leading positionals - # todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ? - - #todo - handle multiple fids? - set fid [lindex $selected_forms 0] - set formdict [dict get $FORMS $fid] - tcl::dict::with formdict {} - #populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc - if {$VAL_MIN eq ""} { - set valmin 0 - set VAL_MIN 0 - } else { - set valmin $VAL_MIN - } - - set pre_values {} - - set argnames [tcl::dict::keys $ARG_INFO] - set optnames [lsearch -all -inline $argnames -*] - set ridx 0 - set rawargs_copy $rawargs - set leader_posn_name "" - set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) - set is_multiple 0 ;#last leader may be multi - if {$LEADER_MAX != 0} { - foreach r $rawargs_copy { - if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { - break - } - if {$ridx == [llength $LEADER_NAMES]-1} { - #at last named leader - set leader_posn_name [lindex $LEADER_NAMES $ridx] - if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { - set is_multiple 1 - } - } elseif {$ridx > [llength $LEADER_NAMES]-1} { - #beyond names - retain name if -multiple was true - if {!$is_multiple} { - set leader_posn_name "" - } - } else { - set leader_posn_name [lindex $LEADER_NAMES $ridx] ;#may return empty string - } - if {$r eq "--"} { - #review end of opts marker: '--' can't be a leader (but can be a value) - break - } - - #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option - if {[tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { - set matchopt [::tcl::prefix::match -error {} $optnames $r] - if {$matchopt ne ""} { - #flaglike matches a known flag - don't treat as leader - break - } - #if {![string match -* [lindex $argnames $ridx]]} {} - if {$leader_posn_name ne ""} { - #there is a named leading positional for this position - #The flaglooking value doesn't match an option - so treat as a leader - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - incr ridx - continue - } else { - break - } - } - - #for each branch - break or lappend - if {$leader_posn_name ne ""} { - if {$leader_posn_name ni $LEADER_REQUIRED} { - #optional leader - - #most adhoc arg processing will allocate based on number of args rather than matching choice values first - #(because a choice value could be a legitimate data value) - - #review - option to process in this manner? - #first check if the optional leader value is a match for a choice ? - #if {[dict exists $arg_info $leader_posn_name -choices]} { - # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] [lindex $rawargs 0]] - # if {$vmatch ne ""} { - # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values - # lappend pre_values [lpop rawargs 0] - # incr ridx - # continue - # } - #} - - #check if enough rawargs to fill any required values - if {$VAL_MIN > 0 && [llength $rawargs] <= $VAL_MIN || [llength $rawargs] <= [llength $VAL_REQUIRED]} { - break - } else { - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #required - if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { - #already accepted at least one value - requirement satisfied - now equivalent to optional - if {$VAL_MIN > 0 && [llength $rawargs] <= $VAL_MIN || [llength $rawargs] <= [llength $VAL_REQUIRED]} { - break - } - } - #if we didn't break - requirement is not yet satisfied, or is satisfied but stil enough rawargs for required values - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #unnamed leader - if {$LEADER_MIN ne "" } { - if {$ridx > $LEADER_MIN-1} { - if {$LEADER_MAX ne "" && $ridx == $LEADER_MAX} { - break - } else { - if {$VAL_MIN ne ""} { - if {[llength $rawargs] > $VAL_MIN} { - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } else { - break - } - } else { - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } - } else { - #haven't reached LEADER_MIN - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - break - } - } - - incr ridx - } ;# end foreach r $rawargs_copy - } - - set argstate $ARG_INFO ;#argstate may have entries added - set arg_checks $ARG_CHECKS - - #JJJJ - if {$LEADER_MIN eq ""} { - set leadermin 0 - } else { - set leadermin $LEADER_MIN - } - if {$LEADER_MAX eq ""} { - set leadermax -1 - } else { - set leadermax $LEADER_MAX - } - - if {$VAL_MAX eq ""} { - set valmax -1 - } else { - set valmax $VAL_MAX - } - - #assert leadermax leadermin are numeric - #assert - rawargs has been reduced by leading positionals - - set opts [dict create] ;#don't set to OPT_DEFAULTS here - - - set leaders [list] - set arglist {} - set post_values {} - #valmin, valmax - #puts stderr "rawargs: $rawargs" - #puts stderr "argstate: $argstate" - if {[lsearch $rawargs -*] >= 0} { - #at least contains flaglike things.. - set maxidx [expr {[llength $rawargs] -1}] - if {$valmax == -1} { - set vals_total_possible [llength $rawargs] - set vals_remaining_possible $vals_total_possible - } else { - set vals_total_possible $valmax - set vals_remaining_possible $vals_total_possible - } - for {set i 0} {$i <= $maxidx} {incr i} { - set a [lindex $rawargs $i] - set remaining_args_including_this [expr {[llength $rawargs] - $i}] - #lowest valmin is 0 - if {$remaining_args_including_this <= $valmin} { - # if current arg is -- it will pass through as a value here - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - - #exlude argument with whitespace from being a possible option e.g dict - if {[tcl::string::match -* $a] && !([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { - if {$a eq "--"} { - #remaining num args <= valmin already covered above - if {$valmax != -1} { - #finite max number of vals - if {$remaining_args_including_this == $valmax} { - #assume it's a value. - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - } else { - #assume it's an end-of-options marker - lappend flagsreceived -- - set arglist [lrange $rawargs 0 $i] - set post_values [lrange $rawargs $i+1 end] - } - } else { - #unlimited number of post_values accepted - #treat this as eopts - we don't care if remainder look like options or not - lappend flagsreceived -- - set arglist [lrange $rawargs 0 $i] - set post_values [lrange $rawargs $i+1 end] - } - break - } else { - set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] - if {$fullopt ne ""} { - if {![tcl::dict::get $argstate $fullopt -prefix] && $a ne $fullopt} { - #attempt to use a prefix when not allowed - #review - by ending opts here - we dont' get the clearest error msgs - # may *sometimes* be better to raise a PUNKARGS VALIDATION (invalidoption) error - # (but it may actually be the first value that just happens to be flaglike) - #todo - check for subsequent valid flags or -- marker? - #consider for example 'file delete -f -- old.txt' - #If we just end option-processing, the punk::args parser would pass {-f -- old.txt} as values - #whereas the builtin file arg parser alerts that -f is a bad option - set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg - #set arglist [lrange $rawargs 0 $i-1] - #set post_values [lrange $rawargs $i end] - #break - } - if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { - #non-solo - #check if it was actually a value that looked like a flag - if {$i == $maxidx} { - #if no optvalue following - assume it's a value - #(caller should probably have used -- before it) - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - - set flagval [lindex $rawargs $i+1] - if {[tcl::dict::get $argstate $fullopt -multiple]} { - #don't lappend to default - we need to replace if there is a default - if {$fullopt ni $flagsreceived} { - tcl::dict::set opts $fullopt [list $flagval] - } else { - tcl::dict::lappend opts $fullopt $flagval - } - if {$fullopt ni $multisreceived} { - lappend multisreceived $fullopt - } - } else { - tcl::dict::set opts $fullopt $flagval - } - #incr i to skip flagval - incr vals_remaining_possible -2 - if {[incr i] > $maxidx} { - set msg "Bad options for %caller%. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $fullopt index [expr {$i-1}]] -badarg $fullopt -argspecs $argspecs]] $msg - } - } else { - #solo - if {[tcl::dict::get $argstate $fullopt -multiple]} { - if {$fullopt ni $flagsreceived} { - #override any default - don't lappend to it - tcl::dict::set opts $fullopt 1 - } else { - tcl::dict::lappend opts $fullopt 1 - } - if {$fullopt ni $multisreceived} { - lappend multisreceived $fullopt - } - } else { - tcl::dict::set opts $fullopt 1 - } - incr vals_remaining_possible -1 - lappend solosreceived $fullopt ;#dups ok - } - lappend flagsreceived $fullopt ;#dups ok - } else { - #unmatched option flag - #comparison to valmin already done above - if {$valmax ne -1 && $remaining_args_including_this <= $valmax} { - #todo - look at optspec_default and see if solo/vs opt-val pair - #we may need to lookahead by 2 regarding valmax valmin - - #even with optany - assume an unknown within the space of possible values is a value - #unmatched option in right position to be considered a value - treat like eopts - #review - document that an unspecified arg within range of possible values will act like eopts -- - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - if {$OPT_ANY} { - set newval [lindex $rawargs $i+1] - #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option - tcl::dict::set argstate $a $OPTSPEC_DEFAULTS ;#use default settings for unspecified opt - tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS - if {[tcl::dict::get $argstate $a -type] ne "none"} { - if {[tcl::dict::get $argstate $a -multiple]} { - tcl::dict::lappend opts $a $newval - if {$a ni $multisreceived} { - lappend multisreceived $a - } - } else { - tcl::dict::set opts $a $newval - } - if {[incr i] > $maxidx} { - set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg - #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a - } - incr vals_remaining_possible -2 - } else { - #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none - if {[tcl::dict::get $argstate $a -multiple]} { - if {![tcl::dict::exists $opts $a]} { - tcl::dict::set opts $a 1 - } else { - tcl::dict::lappend opts $a 1 - } - if {$a ni $multisreceived} { - lappend multisreceived $a - } - } else { - tcl::dict::set opts $a 1 - } - incr vals_remaining_possible -1 - lappend solosreceived $a - } - lappend flagsreceived $a ;#adhoc flag as supplied - } else { - if {[llength $OPT_NAMES]} { - set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" - } else { - set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" - } - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg - #arg_error $errmsg $argspecs -badarg $fullopt - } - } - } - } else { - #not flaglike - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - } - #set values [list {*}$pre_values {*}$post_values] - set leaders $pre_values - set values $post_values - } else { - set leaders $pre_values - set values $rawargs - #set values [list {*}$pre_values {*}$rawargs] ;#no -flags detected - set arglist [list] - } - #puts stderr "--> arglist: $arglist" - #puts stderr "--> values: $values" - - #--------------------------------------- - set ordered_opts [dict create] - foreach o $OPT_NAMES { - if {[dict exists $opts $o]} { - dict set ordered_opts $o [dict get $opts $o] - } elseif {[dict exists $OPT_DEFAULTS $o]} { - dict set ordered_opts $o [dict get $OPT_DEFAULTS $o] - } - } - #add in possible '-any true' opts after the defined opts - dict for {o oval} $opts { - if {![dict exists $ordered_opts $o]} { - dict set ordered_opts $o $oval - } - } - set opts $ordered_opts - #--------------------------------------- - - - set positionalidx 0 ;#index for unnamed positionals (both leaders and values) - set ldridx 0 - set in_multiple "" - set leadernames_received [list] - - set num_leaders [llength $leaders] - #---------------------------------------- - #set leaders_dict $LEADER_DEFAULTS ;#wrong - set leaders_dict [dict create] - foreach lname [lrange $LEADER_NAMES 0 $num_leaders-1] { - dict set leaders_dict $lname {} - } - set leaders_dict [dict merge $leaders_dict $LEADER_DEFAULTS] - #---------------------------------------- - - foreach leadername $LEADER_NAMES ldr $leaders { - if {$ldridx+1 > $num_leaders} { - break - } - if {$leadername ne ""} { - if {[tcl::dict::get $argstate $leadername -multiple]} { - if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { - tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list - } else { - tcl::dict::lappend leaders_dict $leadername $ldr - } - set in_multiple $leadername - } else { - tcl::dict::set leaders_dict $leadername $ldr - } - lappend leadernames_received $leadername - } else { - if {$in_multiple ne ""} { - tcl::dict::lappend leaders_dict $in_multiple $ldr - lappend leadernames_received $in_multiple ;#deliberately allow dups! (as with opts and values) - } else { - tcl::dict::set leaders_dict $positionalidx $ldr - tcl::dict::set argstate $positionalidx $LEADERSPEC_DEFAULTS - tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS - lappend leadernames_received $positionalidx - } - } - incr ldridx - incr positionalidx - } - - - set validx 0 - set valname_multiple "" - set valnames_received [list] - - set num_values [llength $values] - #------------------------------------------ - #!!! review - ## Don't set values_dict to VAL_DEFAULTS - or order of values_dict will be intermittently wrong based on whether values have defaults - ## set values_dict $val_defaults - set values_dict [dict create] - foreach valname [lrange $VAL_NAMES 0 $num_values-1] { - dict set values_dict $valname {} - } - set values_dict [dict merge $values_dict $VAL_DEFAULTS] - #------------------------------------------ - set nameidx 0 - set start_position $positionalidx - for {set validx 0} {$validx < [llength $values]} {incr validx} { - set valname [lindex $VAL_NAMES $nameidx] - incr nameidx - set val [lindex $values $validx] - if {$valname ne ""} { - if {[llength $valname] == 1} { - set strideval $val - } else { - set strideval [list] - incr validx -1 - foreach v $valname { - incr validx - if {$validx > [llength $values]-1} { - set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname', but requires [llength $valname] values." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname] ] -argspecs $argspecs]] $msg - } - lappend strideval [lindex $values $validx] - } - } - - if {[tcl::dict::get $argstate $valname -multiple]} { - if {[tcl::dict::exists $VAL_DEFAULTS $valname]} { - #current stored val equals defined default - don't include default in the list we build up - tcl::dict::set values_dict $valname [list $strideval] ;#important to treat first element as a list - } else { - tcl::dict::lappend values_dict $valname $strideval - } - set valname_multiple $valname - } else { - tcl::dict::set values_dict $valname $strideval - } - lappend valnames_received $valname - } else { - if {$valname_multiple ne ""} { - if {[llength $valname_multiple] == 1} { - set strideval $val - } else { - set strideval [list] - incr validx -1 - foreach v $valname_multiple { - incr validx - if {$validx > [llength $values]-1} { - set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname_multiple', but requires [llength $valname_multiple] values." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname_multiple] ] -argspecs $argspecs]] $msg - } - lappend strideval [lindex $values $validx] - } - } - tcl::dict::lappend values_dict $valname_multiple $strideval - #name already seen - but must add to valnames_received anyway (as with opts and leaders) - lappend valnames_received $valname_multiple - } else { - tcl::dict::set values_dict $positionalidx $val - tcl::dict::set argstate $positionalidx $VALSPEC_DEFAULTS - tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS - lappend valnames_received $positionalidx - } - } - set positionalidx [expr {$start_position + $validx}] - } - #------------------------------------------ - - if {$leadermax == -1} { - #only check min - if {$num_leaders < $leadermin} { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected at least $leadermin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - } - } else { - if {$num_leaders < $leadermin || $num_leaders > $leadermax} { - if {$leadermin == $leadermax} { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected exactly $leadermin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - } else { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - } - } - } - - if {$valmax == -1} { - #only check min - if {$num_values < $valmin} { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $valmin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg - } - } else { - if {$num_values < $valmin || $num_values > $valmax} { - if {$valmin == $valmax} { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $valmin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg - } else { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $valmin and $valmax inclusive" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg - } - } - } - - #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options - - - #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 SHOULD? 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 - - #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? - #example timing difference: - #struct::set difference {x} {a b} - #normal interp 0.18 u2 vs safe interp 9.4us - #if {[llength [set missing [struct::set difference $OPT_REQUIRED $flagsreceived]]]} { - # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" - #} - #if {[llength [set missing [struct::set difference $VAL_REQUIRED $valnames_received]]]} { - # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" - #} - #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us - if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { - set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadermissing $missing received $leadernames_received] -argspecs $argspecs]] $msg - #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - if {[llength [set missing [punklib_ldiff $OPT_REQUIRED $flagsreceived]]]} { - set msg "Required option missing for %caller%. missing flags: '$missing' are marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list optionmissing $missing received $flagsreceived] -argspecs $argspecs]] $msg - #arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs - } - if {[llength [set missing [punklib_ldiff $VAL_REQUIRED $valnames_received]]]} { - set msg "Required value missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list valuemissing $missing received $valnames_received] -argspecs $argspecs]] $msg - #arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - - - #todo - truncate/summarize values in error messages - - #todo - allow defaults outside of choices/ranges - - #check types,ranges,choices - set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] - #set combined_defaults [tcl::dict::merge $VAL_DEFAULTS $OPT_DEFAULTS] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash - #puts "---opts_and_values:$opts_and_values" - #puts "---argstate:$argstate" - tcl::dict::for {argname v} $opts_and_values { - set thisarg [tcl::dict::get $argstate $argname] - #set thisarg_keys [tcl::dict::keys $thisarg] - set thisarg_checks [tcl::dict::get $arg_checks $argname] - set is_multiple [tcl::dict::get $thisarg -multiple] - set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] - set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] - set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] - set has_default [tcl::dict::exists $thisarg -default] - if {$has_default} { - set defaultval [tcl::dict::get $thisarg -default] - } - set type [tcl::dict::get $thisarg -type] - set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] - set regexprepass [tcl::dict::get $thisarg -regexprepass] - set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 - set validationtransform [tcl::dict::get $thisarg -validationtransform] - - - if {$is_multiple} { - set vlist $v - } else { - set vlist [list $v] - } - set vlist_original $vlist ;#retain for possible final strip_ansi - - #review - validationtransform - if {$is_validate_ansistripped} { - #validate_ansistripped 1 - package require punk::ansi - set vlist_check [list] - foreach e $vlist { - lappend vlist_check [punk::ansi::ansistrip $e] - } - } else { - #validate_ansistripped 0 - set vlist_check $vlist - } - - switch -- [Dict_getdef $thisarg -ARGTYPE unknown] { - leader { - set dname leaders_dict - set argclass "Leading argument" - } - option { - set dname opts - set argclass Option - } - value { - set dname values_dict - set argclass "Trailing argument" - } - default { - set dname "_unknown_" ;#NA - set argclass "Unknown argument" - } - } - #reduce our validation requirements by removing values which match defaultval or match -choices - #(could be -multiple with -choicerestriction 0 where some selections match and others don't) - if {$has_choices} { - #-choices must also work with -multiple - #todo -choicelabels - set choiceprefix [tcl::dict::get $thisarg -choiceprefix] - set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] - set choicerestricted [tcl::dict::get $thisarg -choicerestricted] - set choicemultiple [tcl::dict::get $thisarg -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set nocase [tcl::dict::get $thisarg -nocase] - set choices [Dict_getdef $thisarg -choices {}] - set choicegroups [Dict_getdef $thisarg -choicegroups {}] - set allchoices $choices - if {[dict size $choicegroups]} { - dict for {groupname groupmembers} $choicegroups { - lappend allchoices {*}$groupmembers - } - } - #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups - #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes - - - set idx 0 ;# - #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes - #assert llength $vlist == llength [dict get $dname $argname] - # (unless there was a default and the option wasn't specified) - set vlist_validate [list] - set vlist_check_validate [list] - foreach e $vlist e_check $vlist_check { - set allchoices_in_list 0 - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - #vlist and vlist_check can be list of lists if -multiple and -choicemultiple - #each e represents 0 or more choice selections - set c_list $e - set c_check_list $e_check - #todo? check if entire list matches default? - } else { - #only one choice at a time - ensure single entry in c_list c_check_list - set c_list [list $e] - set c_check_list [list $e_check] - } - - - #----------------------------------- - #fast fail on the wrong number of choices - if {[llength $c_list] < $choicemultiple_min} { - set msg "$argclass $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { - set msg "$argclass $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - #----------------------------------- - - set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list - foreach c $c_list c_check $c_check_list { - if {$nocase} { - set casemsg " (case insensitive)" - set choices_test [tcl::string::tolower $allchoices] - #Don't lcase the denylist - even in nocase mode! - #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] - set v_test [tcl::string::tolower $c_check] - } else { - set casemsg " (case sensitive)" - set v_test $c_check - set choices_test $allchoices - } - set choice_in_list 0 - set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? - if {!$matches_default} { - if {$choiceprefix} { - #can we handle empty string as a choice? It should just work - REVIEW/test - set choice_exact_match 0 - if {$c_check in $allchoices} { - #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing - set chosen $c_check - set choice_in_list 1 - set choice_exact_match 1 - } elseif {$v_test in $choices_test} { - #assert - if we're here, nocase must be true - #we know choice is present as full-length match except for case - #now we want to select the case from the choice list - not the supplied value - #we don't set choice_exact_match - because we will need to override the optimistic existing val below - #review - foreach avail [lsort -unique $allchoices] { - if {[string match -nocase $c $avail]} { - set chosen $avail - } - } - #assert chosen will always get set - set choice_in_list 1 - } else { - #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. - #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. - #in this block we can treat empty result from prefix match as a non-match - if {$nocase} { - #nocase implies that our entered value doesn't have to match case of choices - - #but we would still like to select the best match if there are case-dups. - #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete - # selecting Del will find Delete, del will match delete (and raise error) - # but DEL will also match delete rather than Delete - so again an error is raised. - #This is counterintuitive with -nocase - #This is probably such an edge case that best served with documentation as a feature-not-bug - #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? - #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. - - set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] - if {$bestmatch eq ""} { - set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] - #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing - set chosen [lsearch -inline -nocase $allchoices $chosen] - set choice_in_list [expr {$chosen ne ""}] - } else { - set chosen $bestmatch - set choice_in_list 1 - } - } else { - set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] - if {$chosen eq ""} { - set choice_in_list 0 - } else { - set choice_in_list 1 - } - } - #override choice_in_list if in deny list - #don't allow prefixing for elements from -choiceprefixdenylist - #we still use all elements to calculate the prefixes though - #review - case difference edge cases in choiceprefixdenylist !todo - if {$chosen in $choiceprefixdenylist} { - set choice_in_list 0 - set chosen "" - } - } - - #override the optimistic existing val - if {$choice_in_list && !$choice_exact_match} { - if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { - if {$is_multiple} { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $idx $chosen - tcl::dict::set $dname $argname $existing - } else { - tcl::dict::set $dname $argname $chosen - } - } else { - if {$is_multiple} { - set existing_all [tcl::dict::get [set $dname] $argname] - lset existing_all $idx $choice_idx $chosen - tcl::dict::set $dname $argname $existing_all - } else { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $choice_idx $chosen - tcl::dict::set $dname $argname $existing - } - } - } - } else { - #value as stored in $dname is ok - set choice_in_list [expr {$v_test in $choices_test}] - } - } - - if {!$choice_in_list && !$matches_default} { - if {!$choicerestricted} { - #if {$is_multiple} { - # set existing [tcl::dict::get [set $dname] $argname] - # lset existing $idx $v_test - # tcl::dict::set $dname $argname $existing - #} else { - # tcl::dict::set $dname $argname $v_test - #} - lappend vlist_validate $c - lappend vlist_check_validate $c_check - } else { - #unhappy path - if {$choiceprefix} { - set prefixmsg " (or a unique prefix of a value)" - } else { - set prefixmsg "" - } - #review: $c vs $c_check for -badval? - set msg "$argclass '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname - } - } - incr choice_idx - } - - incr idx - } - #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation - #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - - if {[llength $vlist] && $has_default} { - set vlist_validate [list] - set vlist_check_validate [list] - foreach c $vlist c_check $vlist_check { - #for -choicemultiple with default that could be a list use 'ni' ?? review - if {$c_check ne $defaultval} { - lappend vlist_validate $c - lappend vlist_check_validate $c - } - } - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - - #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups - #assert: our vlist & vlist_check lists have been reduced to remove those - if {[llength $vlist] && !$is_allow_ansi} { - #allow_ansi 0 - package require punk::ansi - #do not run ta::detect on a list - foreach e $vlist { - if {[punk::ansi::ta::detect $e]} { - set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - #puts "argname:$argname v:$v is_default:$is_default" - #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. - #arguments that are at their default are not subject to type and other checks - - #don't validate defaults or choices that matched - #puts "---> opts_and_values: $opts_and_values" - #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" - #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} - - #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups - #assert [llength $vlist] == [llength $vlist_check] - if {[llength $vlist]} { - switch -- $type { - literal { - foreach e $vlist { - if {$e ne $argname} { - set msg "$argclass '$argname' for %caller% requires literal value '$argname'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - } - } - } - any {} - list { - foreach e_check $vlist_check { - if {![tcl::string::is list -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[llength $e_check] < $checkval} { - set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[llength $e_check] > $checkval} { - set msg "$argclass '$argname for %caller% requires list with -maxsize $checkval. Received len:[llength $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - } - indexexpression { - foreach e_check $vlist_check { - if {[catch {lindex {} $e_check}]} { - set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - string - ansistring - globstring { - #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string - #we possibly don't want to always have to regex on things that don't pass the other more basic checks - # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) - # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) - # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead - # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function - # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) - # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail - - #todo? - way to validate both unstripped and stripped? - set pass_quick_list_e [list] - set pass_quick_list_e_check [list] - set remaining_e $vlist - set remaining_e_check $vlist_check - #review - order of -regexprepass and -regexprefail in original rawargs significant? - #for now -regexprepass always takes precedence - if {$regexprepass ne ""} { - foreach e $vlist e_check $vlist_check { - if {[regexp $regexprepass $e]} { - lappend pass_quick_list_e $e - lappend pass_quick_list_e_check $e_check - } - } - set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] - set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] - } - if {$regexprefail ne ""} { - foreach e $remaining_e e_check $remaining_e_check { - #puts "----> checking $e vs regex $regexprefail" - if {[regexp $regexprefail $e]} { - if {[tcl::dict::exists $thisarg -regexprefailmsg]} { - #review - %caller% ?? - set msg [tcl::dict::get $thisarg -regexprefailmsg] - } else { - set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" - } - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $e -argspecs $argspecs]] $msg - } - } - } - switch -- $type { - ansistring { - #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi - #.. so we need to look at the original values in $vlist not $vlist_check - - #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? - #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? - package require punk::ansi - foreach e $remaining_e { - if {![punk::ansi::ta::detect $e]} { - set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - } - } - } - globstring { - foreach e $remaining_e { - if {![regexp {[*?\[\]]} $e]} { - set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - } - } - } - } - - if {[tcl::dict::size $thisarg_checks]} { - foreach e_check $remaining_e_check { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[tcl::string::length $e_check] < $checkval} { - set msg "$argclass '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::string::length $e_check] > $checkval} { - set msg "$argclass '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - } - int { - #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive - if {[tcl::dict::exists $thisarg -range]} { - lassign [tcl::dict::get $thisarg -range] low high - if {"$low$high" ne ""} { - if {$low eq ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - #lowside unspecified - check only high - if {$e_check > $high} { - set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $hight. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } elseif {$high eq ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - #highside unspecified - check only low - if {$e_check < $low} { - set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } else { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - #high and low specified - if {$e_check < $low || $e_check > $high} { - set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } else { - foreach e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - double { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is double -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type double. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - if {[tcl::dict::size $thisarg_checks]} { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -range { - #todo - small-value double comparisons with error-margin? review - #todo - empty string for low or high - lassign $checkval low high - if {$e_check < $low || $e_check > $high} { - set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - bool { - foreach e_check $vlist_check { - if {![tcl::string::is boolean -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - dict { - foreach e_check $vlist_check { - if {[llength $e_check] %2 != 0} { - set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[tcl::dict::size $e_check] < $checkval} { - set msg "$argclass '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::dict::size $e_check] > $checkval} { - set msg "$argclass '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - } - alnum - - alpha - - ascii - - control - - digit - - graph - - lower - - print - - punct - - space - - upper - - wordchar - - xdigit { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is $type $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - file - - directory - - existingfile - - existingdirectory { - foreach e $vlist e_check $vlist_check { - #//review - we may need '?' char on windows - if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { - #what about special file names e.g on windows NUL ? - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - if {$type eq "existingfile"} { - foreach e $vlist e_check $vlist_check { - if {![file exists $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } elseif {$type eq "existingdirectory"} { - foreach e $vlist e_check $vlist_check { - if {![file isdirectory $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } - } - char { - #review - char vs unicode codepoint vs grapheme? - foreach e $vlist e_check $vlist_check { - if {[tcl::string::length $e_check] != 1} { - set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } - } - - } - - if {$is_strip_ansi} { - set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach - if {[tcl::dict::get $thisarg -multiple]} { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict $argname $stripped_list - } - option { - tcl::dict::set opts $argname $stripped_list - } - value { - tcl::dict::set values_dict $argname $stripped_list - } - } - } else { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict [lindex $stripped_list 0] - } - option { - tcl::dict::set opts $argname [lindex $stripped_list 0] - } - value { - tcl::dict::set values_dict [lindex $stripped_list 0] - } - } - } - } - } - - #maintain order of opts $opts values $values as caller may use lassign. - set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] - if {[llength $receivednames]} { - #flat zip of names with overall posn, including opts - #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] - set i -1 - set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] - } else { - set received_posns [list] - } - #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) - #(e.g using 'dict exists $received -flag') - # - but it can have duplicate keys when args/opts have -multiple 1 - #It is actually a list of paired elements - return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived multis $multisreceived] - } - - - proc forms {id} { - set spec [get_spec $id] - if {[dict size $spec]} { - return [dict get $spec form_names] - } else { - return [list] - } - } - lappend PUNKARGS [list { - @id -id ::punk::args::synopsis - @cmd -name punk::args::synopsis -help\ - "Return synopsis for each form of a command id - on separate lines. - If -form is given, supply only - the synopsis for that form. - " - @opts - -form -type string -default * - -return -type string -default full -choices {full summary dict} - @values -min 1 -max -1 - cmditem -multiple 1 -optional 0 - }] - proc synopsis {args} { - set argd [punk::args::parse $args withid ::punk::args::synopsis] - - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - if {$has_punkansi} { - set I [punk::ansi::a+ italic] - set RST [punk::ansi::a] - } else { - set I "" - set RST "" - } - - ##set form * - ##if {[lindex $args 0] eq "-form"} { - ## set arglist [lrange $args 2 end] - ## set form [lindex $args 1] - ##} else { - ## set arglist $args - ##} - ##if {[llength $arglist] == 0} { - ## error "punk::args::synopsis expected command id possibly with trailing subcommands/args" - ##} - ##set id [lindex $arglist 0] - ##set cmdargs [lrange $arglist 1 end] - - lassign [dict values $argd] leaders opts values - set form [dict get $opts -form] - set opt_return [dict get $opts -return] - set cmditems [dict get $values cmditem] - set id [lindex $cmditems 0] - set cmdargs [lrange $cmditems 1 end] - - - set spec [get_spec $id] - if {$spec eq ""} { - return - } - set form_names [dict get $spec form_names] - if {$form ne "*"} { - if {[string is integer -strict $form]} { - set f [lindex $form_names $form] - if {$f ne ""} { - set form_names [list $f] - } else { - set form_names [list] - } - } else { - if {$form in $form_names} { - set form_names [list $form] - } else { - set form_names [list] - } - } - } - - set SYND [dict create] - set syn "" - #todo - -multiple etc - foreach f $form_names { - set SYNLIST [list] - dict set SYND $f [list] - append syn "$id" - set forminfo [dict get $spec FORMS $f] - foreach argname [dict get $forminfo LEADER_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set ARGD [dict create argname $argname class leader] - if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - set display [lindex [dict get $arginfo -choices] 0] - } elseif {[dict get $arginfo -type] eq "literal"} { - set display $argname - } else { - set display $I$argname$RST - } - if {[dict get $arginfo -optional]} { - append syn " ?$display?" - } else { - append syn " $display" - } - dict set ARGD type [dict get $arginfo -type] - dict set ARGD optional [dict get $arginfo -optional] - dict set ARGD display $display - dict lappend SYND $f $ARGD - } - foreach argname [dict get $forminfo OPT_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set ARGD [dict create argname $argname class option] - set tp [dict get $arginfo -type] - if {[dict get $arginfo -optional]} { - if {[dict get $arginfo -multiple]} { - if {$tp eq "none"} { - set display "?$argname?..." - } else { - set display "?$argname <$tp>?..." - } - } else { - if {$tp eq "none"} { - set display "?$argname?" - } else { - set display "?$argname <$tp>?" - } - } - } else { - if {[dict get $arginfo -multiple]} { - if {$tp eq "none"} { - set display "$argname ?$argname...?" - } else { - set display "$argname <$tp> ?$argname <$tp>?..." - } - } else { - if {$tp eq "none"} { - set display $argname - } else { - set display "$argname <$tp>" - } - } - } - append syn " $display" - dict set ARGD type [dict get $arginfo -type] - dict set ARGD optional [dict get $arginfo -optional] - dict set ARGD display $display - dict lappend SYND $f $ARGD - } - foreach argname [dict get $forminfo VAL_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set ARGD [dict create argname $argname class value] - if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} { - if {[dict get $arginfo -multiple]} { - set display "?$I$argname$RST?..." - } else { - if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - set display "?[lindex [dict get $arginfo -choices] 0]?" - } elseif {[dict get $arginfo -type] eq "literal"} { - set display "?$argname?" - } else { - set display "?$I$argname$RST?" - } - } - } else { - if {[dict get $arginfo -multiple]} { - set display "$I$argname$RST ?$I$argname$RST?..." - } else { - if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - set display "[lindex [dict get $arginfo -choices] 0]" - } elseif {[dict get $arginfo -type] eq "literal"} { - set display $argname - } else { - set display "$I$argname$RST" - } - } - } - append syn " $display" - dict set ARGD type [dict get $arginfo -type] - dict set ARGD optional [dict get $arginfo -optional] - dict set ARGD display $display - dict lappend SYND $f $ARGD - } - append syn \n - } - switch -- $opt_return { - full { - return [string trim $syn \n] - } - summary { - set summary "" - dict for {form arglist} $SYND { - append summary $id - set class_state leader - set option_count 0 - set value_count 0 - foreach ainfo $arglist { - switch -- [dict get $ainfo class] { - leader { - append summary " [dict get $ainfo display]" - } - option { - incr option_count - } - value { - incr value_count - if {$class_state ne "value"} { - if {$option_count > 0} { - append summary " ?options ($option_count defined)?" - } - set class_state value - } - append summary " [dict get $ainfo display]" - } - } - } - if {$value_count == 0 && $option_count > 0} { - append summary " ?options ($option_count defined)?" - } - append summary \n - } - set summary [string trim $summary \n] - return $summary - } - dict { - return $SYND - } - } - } - - - lappend PUNKARGS [list { - @id -id ::punk::args::synopsis_summary - @cmd -name punk::args::synopsis_summary -help\ - "Reduce the width of a synopsis string - by coalescing options to ?options?... - synopsis string may be arbitrarily marked - up with ANSI codes." - @opts - @values -min 1 -max -1 - synopsis -multiple 0 -optional 0 - }] - proc synopsis_summary {args} { - set argd [punk::args::parse $args withid ::punk::args::synopsis_summary] - set synopsis [dict get $argd values synopsis] - set summary "" - foreach sline [split $synopsis \n] { - set sline [regsub -all {\s+} $sline " "] ;#normalize to single spacing only - review - set in_opt 0 - set line_out "" - set codestack [list] - set parts [punk::ansi::ta::split_codes_single $sline] - #basic - foreach {pt code} $parts { - set charlist [split $pt ""] - for {set i 0} {$i < [llength $charlist]} {incr i} { - set c [lindex $charlist $i] - - switch -- $c { - ? { - if {!$in_opt} { - set in_opt 1 - } else { - - } - } - " " { - if {!$in_opt} { - append line_out " " - } else { - set in_opt - } - } - default { - if {!$in_opt} { - append line_out $c - } - } - } - } - if {$code ne ""} { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set codestack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set codestack [list $code] - } elseif {[punk::ansi::codetype::is_sgr $code]} { - #basic simplification first - remove straight dupes - set dup_posns [lsearch -all -exact $codestack $code] ;#must be -exact because of square-bracket glob chars - set codestack [lremove $codestack {*}$dup_posns] - lappend codestack $code - } else { - #? ignore other ANSI codes? - } - } - } - if {[string match -* $plain_s] || [string match ?- $plain_s]} { - } - } - return $summary - } - - lappend PUNKARGS [list { - @id -id ::punk::args::TEST - @opts -optional 0 - -o1 -default 111 -help "opt 1 mandatory" - @opts -optional 1 - -o2 -default 222 -help "opt 2 optional" - @values -min 0 -max 1 - v -help\ - "v1 optional" - }] - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::lib { - variable PUNKARGS - tcl::namespace::export * - tcl::namespace::path [list [tcl::namespace::parent]] - #*** !doctools - #[subsection {Namespace punk::args::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 flatzip {l1 l2} { - concat {*}[lmap a $l1 b $l2 {list $a $b}] - } - - if {[info commands lseq] ne ""} { - #tcl 8.7+ lseq significantly faster, especially for larger ranges - #The internal rep can be an 'arithseries' with no string representation - proc zero_based_posns {count} { - if {$count < 1} {return} - lseq 0 $count-1 - } - } else { - proc zero_based_posns {count} { - if {$count < 1} {return} - lsearch -all [lrepeat $count 0] * - } - } - - #return list of single column-width marks - possibly with ansi - proc choiceinfo_marks {choice choiceinfodict} { - set marks [list] - if {[dict exists $choiceinfodict $choice]} { - set cinfo [dict get $choiceinfodict $choice] - foreach info $cinfo { - if {[lindex $info 0] eq "doctype"} { - switch -- [lindex $info 1] { - punkargs { - lappend marks [punk::ns::Cmark punkargs brightgreen] - } - ensemble { - lappend marks [punk::ns::Cmark ensemble brightyellow] - } - oo { - lappend marks [punk::ns::Cmark oo brightcyan] - } - ooc { - lappend marks [punk::ns::Cmark ooc cyan] - } - ooo { - lappend marks [punk::ns::Cmark ooo cyan] - } - native { - lappend marks [punk::ns::Cmark native] - } - unknown { - lappend marks [punk::ns::Cmark unknown brightred] - } - } - } - } - } - return $marks - } - - - #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 -1] in calling scope ${[lindex [set x] 0]} !} - lappend PUNKARGS [list { - @id -id ::punk::args::lib::tstr - @cmd -name punk::args::lib::tstr -help\ - "A rough equivalent of js template literals - - Substitutions: - \$\{$varName\} - \$\{[myCommand]\} - (when -allowcommands flag is given)" - -allowcommands -default 0 -type none -help\ - "If -allowcommands is present, placeholder can contain commands - e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" - -undent -default 1 -type boolean -help\ - "undent/dedent the template lines. - The longest common prefix of whitespace is removed" - -indent -default "" -type string -help\ - "String with which to indent the template - prior to substitution. - If -undent is enabled, that is performed - first, then the indent is applied." - -paramindents -default line -choices {none line position} -choicelabels { - line\ - " Use leading whitespace in - the line in which the - placeholder occurs." - position\ - " Use the position in - the line in which the - placeholder occurs." - none\ - " No indents applied to - subsequent placeholder value - lines. This will usually - result in text awkwardly - ragged unless the source code - has also been aligned with the - left margin or the value has - been manually padded." - } -help\ - "How indenting is done for subsequent lines in a - multi-line placeholder substitution value. - The 1st line or a single line value is always - placed at the placeholder. - paramindents are performed after the main - template has been indented/undented. - (indenting by position does not calculate - unicode double-wide or grapheme cluster widths) - " - #choicelabels indented by 1 char is clearer for -return string - and reasonable in table - -return -default string -choices {dict list string args}\ - -choicelabels { - dict\ - " Return a dict with keys - 'template', 'params' and - 'errors'" - string\ - " Return a single result - being the string with - placeholders substituted." - list\ - " Return a 2 element list. - The first is itself a list - of plaintext portions of the - template, split at each point - at which placeholders were - present. The second element - of the outer list is a list - of placeholder values if -eval - is 1, or a list of the raw - placeholder strings if -eval - is 0." - args\ - " Return a list where the first - element is a list of template - plaintext sections as per the - 'list' return mechanism, but the - placeholder items are individual - items in the returned list. - This can be useful when passing - the expanded result of a tstr - command to another function - which expects the placeholders - as individual arguments" - } - -eval -default 1 -type boolean -help\ - "Whether to evaluate the \$\{\} placeholders. - When -return is string, -eval should generally be set to 1. - For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. - contained variables in that case should be braced or whitespace separated, or the variable - name is likely to collide with surrounding text. - e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" - @values -min 0 -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 - e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} - - Escape sequences such as \\n and unicode escapes are processed within placeholders. - " - }] - - proc tstr {args} { - #Too hard to fully eat-our-own-dogfood from within punk::args package - # - we use punk::args within the unhappy path only - #set argd [punk::args::get_by_id ::punk::lib::tstr $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 opt_eval [dict get $argd opts -eval] - - set templatestring [lindex $args end] - set arglist [lrange $args 0 end-1] - set opts [dict create\ - -allowcommands 0\ - -undent 1\ - -indent ""\ - -paramindents line\ - -eval 1\ - -return string\ - ] - if {"-allowcommands" in $arglist} { - set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] - dict set opts -allowcommands 1 - } - if {[llength $arglist] % 2 != 0} { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr expected option/value pairs prior to last argument" - } - } - dict for {k v} $arglist { - set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] - switch -- $fullk { - -indent - -undent - -paramindents - -return - -eval { - dict set opts $fullk $v - } - default { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" - } - } - } - } - set opt_allowcommands [dict get $opts -allowcommands] - set opt_paramindents [dict get $opts -paramindents] - set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] - if {$test_paramindents ni {none line position}} { - error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." - } - set opt_paramindents $test_paramindents - set opt_return [dict get $opts -return] - set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] - if {$opt_return eq ""} { - } - set opt_eval [dict get $opts -eval] - - - set nocommands "-nocommands" - if {$opt_allowcommands == 1} { - set nocommands "" - } - - set opt_undent [dict get $opts -undent] - if {$opt_undent} { - set templatestring [punk::args::lib::undent $templatestring] - } - set opt_indent [dict get $opts -indent] - if {$opt_indent ne ""} { - set templatestring [punk::args::lib::indent $templatestring $opt_indent] - } - - #set parts [_tstr_split $templatestring] - if {[string first \$\{ $templatestring] < 0} { - set parts [list $templatestring] - } else { - set parts [_parse_tstr_parts $templatestring] - } - set textchunks [list] - #set expressions [list] - set params [list] - set idx 0 - set errors [dict create] - set lastline "" ;#todo - first line has placeholder? - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach {pt expression} $parts { - lappend textchunks $pt - incr idx ;#pt incr - - #ignore last expression - if {$idx == [llength $parts]} { - break - } - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - #lappend expressions $expression - #---------------------- - #REVIEW - JMN - #TODO - debug punk::args loading of @dynamic defs - #puts "-- $expression" - #---------------------- - #brk1 - literal newline not {\n} - set leader "" - if {[set brk1 [string first \n $expression]] >= 0} { - #undent left of paramstart only for lines of expression that arent on opening ${..} line - set tail [string range $expression $brk1+1 end] - set leader [string repeat " " [string length $lastline]] - set undentedtail [punk::args::lib::undentleader $tail $leader] - #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] - set expression "[string range $expression 0 $brk1]$undentedtail" - } - if {$opt_eval} { - if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { - lappend params [string cat \$\{ $expression \}] - dict set errors [expr {[llength $params]-1}] $result - } else { - set result [string map [list \n "\n$leader"] $result] - lappend params $result - } - #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] - } else { - lappend params [subst -nocommands -novariables $expression] - } - append lastline [lindex $params end] ;#for current expression's position calc - - incr idx ;#expression incr - } - - if {$opt_return eq "dict"} { - return [dict create template $textchunks params $params errors $errors] - } - if {[dict size $errors]} { - set einfo "" - dict for {i e} $errors { - append einfo "parameter $i error: $e" \n - } - #REVIEW!!! - #TODO - fix - #puts stderr "tstr errors:\n$einfo\n" - } - - switch -- $opt_return { - list { - return [list $textchunks $params] - } - args { - #see example in tstr_test_one - return [list $textchunks {*}$params] - } - string { - #todo - flag to disable indent-matching behaviour for multiline param? - set out "" - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach pt $textchunks param $params { - if {$opt_paramindents eq "none"} { - append out $pt $param - } else { - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - if {$opt_paramindents eq "line"} { - regexp {(\s*).*} $lastline _all lastindent - } else { - #position - #TODO - detect if there are grapheme clusters - #This regsub doesn't properly space unicode double-wide chars or clusters - set lastindent "[regsub -all {\S} $lastline " "] " - } - if {$lastindent ne ""} { - set paramlines [split $param \n] - if {[llength $paramlines] == 1} { - append out $pt $param - } else { - append out $pt [lindex $paramlines 0] - foreach nextline [lrange $paramlines 1 end] { - append out \n $lastindent $nextline - } - } - } else { - append out $pt $param - } - append lastline $param - } - } - return $out - } - } - } - #test single placeholder tstr args where single placeholder must be an int - proc tstr_test_one {args} { - set argd [punk::args::parse $args withdef { - @cmd -name ::punk::args::lib::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 -return args {Select * from table where id = \$\{$id\} and etc... ;}] - } - - @values -min 2 -max 2 - template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - - but the tstr call in the example 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} - }] - 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]] ""] - set result [string cat [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 dollar sign - 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]] - } - - #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. - proc indent {text {prefix " "}} { - set result [list] - foreach line [split $text \n] { - if {[string trim $line] eq ""} { - lappend result "" - } else { - lappend result $prefix[string trimright $line] - } - } - return [join $result \n] - } - #dedent? - proc undent {text} { - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - regexp {^([\t ]*)} $lcp _m lcp - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - - #hacky - proc undentleader {text leader} { - #leader usually whitespace - but doesn't have to be - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - lappend nonblank "${leader}!!" - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - #regexp {^([\t ]*)} $lcp _m lcp - #lcp can be shorter than leader - set lcp [string range $lcp 0 [string length $leader]-1] - - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - #A version of textutil::string::longestCommonPrefixList - proc longestCommonPrefix {items} { - if {[llength $items] <= 1} { - return [lindex $items 0] - } - set items [lsort $items[unset items]] - set min [lindex $items 0] - set max [lindex $items end] - #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) - #(sort order nothing to do with length - e.g min may be longer than max) - if {[string length $min] > [string length $max]} { - set temp $min - set min $max - set max $temp - } - set n [string length $min] - set prefix "" - set i -1 - while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { - append prefix $c - } - return $prefix - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] -} - -tcl::namespace::eval punk::args::argdocbase { - namespace export * - #use a? to test and create literal ansi here rather than relying on punk::ansi package presence - #e.g - #% a? bold - #- bold │SGR 1│sample│␛[1msample - #- ──────┼─────┼──────┼────────── - #- RESULT│ │sample│␛[1msample - proc B {} {return \x1b\[1m} ;#a+ bold - proc N {} {return \x1b\[22m} ;#a+ normal - proc I {} {return \x1b\[3m} ;#a+ italic - proc NI {} {return \x1b\[23m} ;#a+ noitalic - -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::package { - variable PUNKARGS - lappend PUNKARGS [list { - @dynamic - @id -id "::punk::args::package::standard_about" - @cmd -name "%pkg%::about" -help\ - "About %pkg% - ... - " - -package_about_namespace -type string -optional 0 -help\ - "Namespace containing the package about procedures - Must contain " - -return\ - -type string\ - -default table\ - -choices {string table tableobject}\ - -choicelabels { - string\ - "A basic text layout" - table\ - "layout in table borders - (requires package: textblock)" - tableobject\ - "textblock::class::table object instance" - }\ - -help\ - "Choose the return type of the 'about' information" - topic -optional 1\ - -nocase 1\ - -default {*}\ - -choices {Description License Version Contact *}\ - -choicerestricted 0\ - -choicelabels { - - }\ - -multiple 1\ - -help\ - "Topic to display. Omit or specify as * to see all. - If * is included with explicit topics, * represents - the remaining unmentioned topics." - }] - proc standard_about {args} { - set argd [punk::args::parse $args withid ::punk::args::package::standard_about] - lassign [dict values $argd] leaders OPTS values received - - set pkgns [dict get $OPTS -package_about_namespace] - if {[info commands ${pkgns}::package_name] eq ""} { - error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" - } - set pkgname [${pkgns}::package_name] - - set opt_return [dict get $OPTS -return] - set all_topics [${pkgns}::about_topics] - if {![dict exists $received topic]} { - set topics $all_topics - } else { - # * represents all remaining topics not explicitly mentioned. - set val_topics [dict get $values topic] ;#if -multiple is true, this is a list - set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] - set topics [list] - foreach t $val_topics { - if {$t eq "*"} { - foreach a $all_topics { - if {$a ni $explicit_topics} { - lappend topics $a - } - } - } else { - lappend topics $t - } - } - } - if {$opt_return ne "string"} { - package require textblock ;#table support - set is_table 1 - set title [string cat {[} $pkgname {]} ] - set t [textblock::class::table new -title $title] - $t configure -frametype double -minwidth [expr {[string length $title]+2}] - - } else { - set topiclens [lmap t $topics {string length $t}] - set widest_topic [tcl::mathfunc::max {*}$topiclens] - set is_table 0 - set about "$pkgname\n" - append about [string repeat - $widest_topic] \n - } - foreach topic $topics { - if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { - set topic_contents [::${pkgns}::get_topic_$topic] - } else { - set topic_contents "" - } - if {!$is_table} { - set content_lines [split $topic_contents \n] - append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n - foreach ln [lrange $content_lines 1 end] { - append about [format %-${widest_topic}s ""] " " $ln \n - } - } else { - $t add_row [list $topic $topic_contents] - } - } - - if {!$is_table} { - return $about - } else { - if {$opt_return eq "tableobject"} { - return $t - } - set result [$t print] - $t destroy - return $result - } - } - -} - -#usually we would directly call arg definitions near the defining proc, -# so that the proc could directly use the definition in its parsing. -# -#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. -#arguably it may be more processor-cache-efficient to do together like this anyway. - -#can't do this here? - as there is circular dependency with punk::lib -#tcl::namespace::eval punk::args { -# foreach deflist $PUNKARGS { -# punk::args::define {*}$deflist -# } -# set PUNKARGS "" -#} - -lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -tcl::namespace::eval punk::args::system { - #*** !doctools - #[subsection {Namespace punk::args::system}] - #[para] Internal functions that are not part of the API - - #dict get value with default wrapper for tcl 8.6 - if {[info commands ::tcl::dict::getdef] eq ""} { - proc Dict_getdef {dictValue args} { - set keys [lrange $args 0 end-1] - if {[tcl::dict::exists $dictValue {*}$keys]} { - return [tcl::dict::get $dictValue {*}$keys] - } else { - return [lindex $args end] - } - } - } else { - #we pay a minor perf penalty for the wrap - interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef - } - - #name to reflect maintenance - home is punk::lib::ldiff - proc punklib_ldiff {fromlist removeitems} { - if {[llength $removeitems] == 0} {return $fromlist} - set result {} - foreach item $fromlist { - if {$item ni $removeitems} { - lappend result $item - } - } - return $result - } - -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::args [tcl::namespace::eval punk::args { - tcl::namespace::path {::punk::args::lib ::punk::args::system} - variable pkg punk::args - variable version - set version 0.1.6 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.7.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.7.tm deleted file mode 100644 index b04f4966..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.7.tm +++ /dev/null @@ -1,6458 +0,0 @@ -# -*- 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: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.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 punk::args 0.1.7 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.1.7] -#[copyright "2024"] -#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] -#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] -#[require punk::args] -#[keywords module proc args arguments parse] -#[description] -#[para]Utilities for parsing proc args - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). -#[para] overview of punk::args -#[subsection Concepts] -#[para]There are 2 main conventions for parsing a proc args list -#[list_begin enumerated] -#[enum] -#[para]leading option-value pairs and flags followed by a list of values (Tcl style) -#[enum] -#[para]leading list of values followed by option-value pairs and flags (Tk style) -#[list_end] -#[para]There are exceptions in both Tcl and Tk commands regarding this ordering -#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style -#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] -#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. -#[para] -#[para]The basic principle is that a call to punk::args::parse is made near the beginning of the proc with a cacheable argument defining the parameters e.g -#[example { -# proc dofilestuff {args} { -# lassign [dict values [punk::args::parse $args withdef { -# @cmd -help "do some stuff with files e.g dofilestuff " -# @opts -type string -# #comment lines ok -# -directory -default "" -# -translation -default binary -# #setting -type none indicates a flag that doesn't take a value (solo flag) -# -nocomplain -type none -# @values -min 1 -max -1 -# }]] leaders opts values -# -# puts "translation is [dict get $opts -translation]" -# foreach f [dict values $values] { -# puts "doing stuff with file: $f" -# } -# } -#}] -#[para]The lines beginning with @ are usually optional in most cases and can be used to set defaults and some extra controls -#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values -#[para]valid @ lines being with @cmd @leaders @opts @values -#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. -#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. -#[para]e.g the result from the punk::args::parse call above may be something like: -#[para] leaders {} opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} -#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments -#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments -#[para]This could also be implemented entirely using args - and the @leaders category of arguments -#[example { -# proc dofilestuff {category args} { -# lassign [dict values [punk::args::parse $args withdef { -# @id -id ::dofilestuff -# -directory -default "" -# -translation -default binary -# -nocomplain -type none -# @values -min 2 -max 2 -# fileA -type existingfile 1 -# fileB -type existingfile 1 -# }]] leaders opts values -# puts "$category fileA: [dict get $values fileA]" -# puts "$category fileB: [dict get $values fileB]" -# } -#}] -#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 -#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored -#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, -#[para] or an additional call could be made to punk::args e.g -#[example { -# punk::args::parse [list $category $another_leading_arg] withdef { -# category -choices {cat1 cat2 cat3} -# another_leading_arg -type boolean -# } -#}] - -#*** !doctools -#[subsection Notes] -#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. -#[para] -#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. -#For functions that are part of an API a package may be more suitable. -#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) -#[example { -# proc test_switch {args} { -# set opts [dict create\\ -# -return "object"\\ -# -frametype "heavy"\\ -# -show_edge 1\\ -# -show_seps 0\\ -# -x a\\ -# -y b\\ -# -z c\\ -# -1 1\\ -# -2 2\\ -# -3 3\\ -# ] -# foreach {k v} $args { -# switch -- $k { -# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { -# dict set opts $k $v -# } -# default { -# error "unrecognised option '$k'. Known options [dict keys $opts]" -# } -# } -# } -# return $opts -# } -#}] -#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. -#[para] -# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. -# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. -#[para]use punk::lib::show_jump_tables to verify that a jump table exists. -#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous -#[example { -# proc test_prefix {args} { -# set opts [dict create\ -# -return string\ -# -frametype \uFFEF\ -# -show_edge \uFFEF\ -# -show_seps \uFFEF\ -# -x a\ -# -y b\ -# -z c\ -# -1 1\ -# -2 2\ -# -3 3\ -# ] -# if {[llength $args]} { -# set knownflags [dict keys $opts] -# } -# foreach {k v} $args { -# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v -# } -# return $opts -# } -#}] -#[para]There are many alternative args parsing packages a few of which are listed here. -#[list_begin enumerated] -#[enum]argp (pure tcl) -#[enum]parse_args (c implementation) -#[enum]argparse (pure tcl *) -#[enum]cmdline (pure tcl) -#[enum]opt (pure tcl) distributed with Tcl but considered deprecated -#[enum]The tcllib set of TEPAM modules (pure tcl) -#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. -#[list_end] -#[para] (* c implementation planned/proposed) -#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. -#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences -#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. -#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. -#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. -#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. -#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -#All ensemble commands are slower in a safe interp as they aren't compiled the same way -#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 -#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. -#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) -#ensembles: array binary clock dict info namespace string -#possibly file too, although that is generally hidden/modified in a safe interp -#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc -#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::args -#[list_begin itemized] -package require Tcl 8.6- -#optional? punk::trie -#optional? punk::textblock -#*** !doctools -#[item] [package {Tcl 8.6-}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -tcl::namespace::eval punk::args::register { - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] cooperative namespace punk::args::register - #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded - #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. - #[list_begin definitions] - - #Although the actual punk::args::define calls are not too sluggish, there could be *many*. - #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, - #especially since a fair proportion may be for documentation purposes rather than parsing args. - - # -- --- --- --- --- --- --- --- - #cooperative with packages that define some punk args but do so lazily - #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first - variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective - if {![info exists ::punk::args::register::NAMESPACES]} { - set ::punk::args::register::NAMESPACES [list] - } - # -- --- --- --- --- --- --- --- - - variable loaded_packages - if {![info exists loaded_packages]} { - set loaded_packages [list] ;#fully loaded - } - variable loaded_info - if {![info exists loaded_info]} { - set loaded_info [dict create] ;#time - } - variable scanned_packages - if {![info exists scanned_packages]} { - set scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages - } - variable scanned_info ;#time and idcount - if {![info exists scanned_info]} { - set scanned_info [dict create] - } - #some packages, e.g punk::args::tclcore document other namespaces. - #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources - variable namespace_docpackages - if {![info exists namespace_docpackages]} { - set namespace_docpackages [dict create] - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::register ---}] -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args { - - - variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. - - tcl::namespace::export {[a-z]*} - variable rawdef_cache - if {![info exists rawdef_cache]} { - set rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} - } - variable id_cache_rawdef - if {![info exists id_cache_rawdef]} { - set id_cache_rawdef [tcl::dict::create] - } - variable id_cache_spec - if {![info exists id_cache_spec]} { - set id_cache_spec [tcl::dict::create] - } - - variable argdefcache_unresolved - if {![info exists argdefcache_unresolved]} { - set argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) - } - - variable argdata_cache - if {![info exists argdata_cache]} { - set argdata_cache [tcl::dict::create] - } - - variable id_counter - if {![info exists id_counter]} { - set id_counter 0 - } - - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] Core API functions for punk::args - #[list_begin definitions] - - #todo - some sort of punk::args::cherrypick operation to get spec from an existing set - #todo - doctools output from definition - - - - - #todo? -synonym/alias ? (applies to opts only not values) - #e.g -background -aliases {-bg} -default White - #review - how to make work with trie prefix - #e.g - # -corner -aliases {-corners} - # -centre -aliases {-center -middle} - #We mightn't want the prefix to be longer just because of an alias - #we should get -co -ce and -m from the above as abbreviations - - set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] - - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::define - #todo @preamble -help "move large block outside of table?" - @cmd -name punk::args::define -help\ - "Accepts a line-based definition of command arguments. - The definition can be supplied as a single text block or multiple as described - in the help information for 'text' below. - - Returns an id which is a key to the stored definition. - The id is taken from the supplied definition's @id -id line, or is an - automatically created id of the form 'autoid_'. - - At the time define is called - just the raw text arguments are stored for the id. - When the id is first used, for example with 'punk::args::parse $args withid $id', - the raw definition is parsed into a stored specifications dictionary. - - This specifications dictionary is structured for (optional) use within commands to - parse and validate the arguments - and is also used when retrieving definitions - (or parts thereof) for re-use. - - This can be used purely for documentation or called within a function to parse a mix - of leading values, switches/flags and trailing values. - - The overhead is favourably comparable with other argument processors - but none are - as fast as minimal code with a switch statement. For toplevel commands where a few - 10s of microseconds is immaterial, the validation and automated error formatting in - a table can be well worthwhile. For inner procs requiring utmost speed, the call can - be made only on the unhappy path when basic processing determines a mismatch - or it - can be left entirely as documentation for interactive use with: i ... - and for synopsis generation with: s ... - - The definition should usually contain an initial line of the form: @id -id ::somecmd - - Blank lines are ignored at the top level, ie if they are not part of another structure. - Similarly - lines at the top level beginning with the # character are ignored. - All other toplevel lines must consist of a leading word followed by paired arguments. - The arguments can be spread over multiple lines and contain lines of near-arbitrary - text if they are properly braced or double quoted and Tcl escaping for inner quotes - or unbalanced braces is maintained. - The line continuation character - (\\ at the end of the line) can be used to continue the set of arguments for - a leading word. - Leading words beginning with the @ character are directives controlling argument - parsing, defaults for subsequent arguments, and help display. - directives include: - %B%@id%N% ?opt val...? - directive-options: -id - %B%@cmd%N% ?opt val...? - directive-options: -name -help - %B%@leaders%N% ?opt val...? - directive-options: -min -max - (used for leading args that come before switches/opts) - %B%@opts%N% ?opt val...? - directive-options: -any - %B%@values%N% ?opt val...? - directive-options: -min -max - (used for trailing args that come after switches/opts) - %B%@form%N% ?opt val...? - directive-options: -form -synopsis - (used for commands with multiple forms) - The -synopsis value allows overriding the auto-calculated - synopsis. - %B%@formdisplay%N% ?opt val...? - directive-options: -header (text for header row of table) - -body (override autogenerated arg info for form) - %B%@doc%N% ?opt val...? - directive-options: -name -url - %B%@seealso%N% ?opt val...? - directive-options: -name -url (for footer - unimplemented) - - Some other options normally present on custom arguments are available - to use with the @leaders @opts @values directives to set defaults - for subsequent lines that represent your custom arguments. - These 3 directives should occur in exactly this order - but can be - repeated with custom argument lines interspersed. - - An @id line can only appear once and should be the first item. - For the commandline usage to be displayed either on parsing error - or using the i .. function - an @id with -id is needed. - - All directives can be omitted, in which case every line represents - a custom leader, value or option. - All will be leaders by default if no options defined. - If options are defined (by naming with leading dash, or explicitly - specifying @opts) then the definitions prior to the options will be - categorised as leaders, and those following the options will be - categorised as values. - - Custom arguments are defined by using any word at the start of a - line that doesn't begin with @ or - - (except that adding an additionl @ escapes this restriction so - that @@somearg becomes an argument named @somearg) - - custom leading args, switches/options (names starting with -) - and trailing values also take spec-options: - - -type - defaults to string. If no other restrictions - are specified, choosing string does the least validation. - recognised types: - none - (used for switches only. Indicates this is - a 'solo' flag ie accepts no value) - int|integer - list - indexexpression - dict - double - bool|boolean - char - file - directory - string - ansistring - globstring - (any of the types accepted by 'string is') - - These all perform some validation checks - - and more.. (todo - document here) - - -optional - (defaults to true for flags/switches false otherwise) - For non flag/switch arguments - all arguments with - -optional true must sit consecutively within their group. - ie all optional leader arguments must be together, and all - optional value arguments must be together. Furthermore, - specifying both optional leaders and optional values will - often lead to ambiguous parsing results. Currently, all - optional non-flg/switch arguments should be either at the - trailing end of leaders or the trailing end of values. - Further unambiguous arrangements of optional args may be - made in future - but are currently considered 'unsupported' - -default - -multiple (for leaders & values defines whether - subsequent received values are stored against the same - argument name - only applies to final leader OR final value) - (for options/flags this allows the opt-val pair or solo - flag to appear multiple times - not necessarily contiguously) - -choices {} - A list of allowable values for an argument. - The -default value doesn't have to be in the list. - If a -type is specified - it doesn't apply to choice members. - It will only be used for validation if the -choicerestricted - option is set to false. If all choices are specified in values - within the -choicegroups dict, it is not necessary to specify them - in the -choices list. It is effectively a simpler form of - specifying choices when no grouping is required. It is fine to - use both -choices and -choicegroups e.g specifying all in -choices - and then including only some that need grouping in -choicegroups. - -choicelabels {} - keys are the values/argument names from -choices (or equivalently - members of value entries from the -choicegroups dict) - The values in the choicelabels dict are text values, possibly - containing newlines, that are displayed below each choice. - This is commonly a very basic summary of the choice. In the - case of a subcommand it may be a usage synopsis for further - arguments. - -choicerestricted - Whether values not specified in -choices or -choicegroups are - allowed. Defaults to true. - -choiceprefix - This specifies whether unique prefixes are able to be used - instead of the complete string. This is calculated using - tcl::prefix::match - and will display in the autogenerated - usage output. Defaults to true. - -choiceprefixdenylist {} - These choices should match exactly a choice entry in one of - the settings -choices or -choicegroups. - These will still be used in prefix calculation - but the full - choice argument must be entered to select the choice. - -choicegroups {} - Generally this would be used instead of -choices to allow - usage display of choices grouped by some name (or the empty - string for 'ungrouped' items which appear first). - See for example the output if 'i zlib' where choices of the - next subcommand are grouped by the names compression,channel, - streaming and checksumming. The -choices list is equivalent - to a -choicegroups dict entry where the key (groupname) is - the empty string. Both may be specified, in which case the - final list of available choices will be a union of the listed - values in -choices and the values from each choice group. - Choice values specified in -choices are effectively ungrouped - unless overridden by placing them in a choicegroup. - -choicemultiple (default {1 1}) - is a pair representing min and max number of choices - that can be present in the value. - If is a single integer it is equivalent to a - specified with the same integer for both min and max. - Max of -1 represents no upper limit. - If allows more than one choice the value is a list - consisting of items in the choices made available through - entries in -choices/-choicegroups. - -minsize (type dependant) - -maxsize (type dependant) - -range (type dependant) - - - " - -dynamic -type boolean -default 0 -help\ - "If -dynamic is true, tstr interpolations of the form \$\{\$var\} - are re-evaluated on each call. - If the definition is being used not just as documentation, but is also - used within the function to parse args, e.g using punk::args::get_by_id, - then it should be noted that there is a slight performance penalty for the - dynamic case. - It is often not significant, perhaps depending on what vars/commands are - used but -dynamic true might be less desirable if the command is used in - inner loops in more performance-sensitive code. - " - @values -min 1 -max -1 - text -type string -multiple 1 -help\ - "Block(s) of text representing the argument definition for a command. - At least one must be supplied. If multiple, they are joined together with \\n. - Using multiple text arguments may be useful to mix curly-braced and double-quoted - strings to have finer control over interpolation when defining arguments. - (this can also be handy for sections that pull resolved definition lines - from existing definitions (by id) for re-use of argument specifications and help text) - - e.g the following definition passes 2 blocks as text arguments - definition { - @id -id ::myns::myfunc - @cmd -name myns::myfunc -help\\ - \"Description of command\" - - #The following option defines an option-value pair - -option1 -default blah -type string - #The following option defines a flag style option (solo) - -flag1 -default 0 -type none -help\\ - \"Info about flag1 - subsequent help lines auto-dedented by whitespace to left - of corresponding record start (in this case -flag1) - + first 4 spaces if they are all present. - This line has no extra indent relative to first line 'Info about flag1' - This line indented a further 6 chars\" - - @values -min 1 -max -1 - #Items that don't begin with * or - are value definitions - v1 -type integer -default 0 - thinglist -type string -multiple 1 - } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" - " - }]] - - proc New_command_form {name} { - #probably faster to inline a literal dict create in the proc than to use a namespace variable - set leaderspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - -ensembleparameter 0\ - ] - set optspec_defaults [tcl::dict::create\ - -type string\ - -optional 1\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - -prefix 1\ - ] - set valspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - - #form record can have running entries such as 'argspace' that aren't given to arg parser - #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict - return [dict create\ - argspace "leaders"\ - ARG_INFO [tcl::dict::create]\ - ARG_CHECKS [tcl::dict::create]\ - LEADER_DEFAULTS [tcl::dict::create]\ - LEADER_REQUIRED [list]\ - LEADER_NAMES [list]\ - LEADER_MIN ""\ - LEADER_MAX ""\ - LEADERSPEC_DEFAULTS $leaderspec_defaults\ - LEADER_CHECKS_DEFAULTS {}\ - OPT_DEFAULTS [tcl::dict::create]\ - OPT_REQUIRED [list]\ - OPT_NAMES [list]\ - OPT_ANY 0\ - OPT_SOLOS {}\ - OPTSPEC_DEFAULTS $optspec_defaults\ - OPT_CHECKS_DEFAULTS {}\ - VAL_DEFAULTS [tcl::dict::create]\ - VAL_REQUIRED [list]\ - VAL_NAMES [list]\ - VAL_MIN ""\ - VAL_MAX ""\ - VALSPEC_DEFAULTS $valspec_defaults\ - VAL_CHECKS_DEFAULTS {}\ - FORMDISPLAY [tcl::dict::create]\ - ] - - } - - proc errorstyle {args} { - #set or query the running config -errorstyle - #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? - #values: - #debug, enhanced, standard, basic, minimal - error todo - } - proc define {args} { - variable rawdef_cache - variable id_cache_rawdef - variable argdata_cache - if {[dict exists $rawdef_cache $args]} { - return [dict get [dict get $rawdef_cache $args] -id] - } else { - set id [rawdef_id $args] - if {[id_exists $id]} { - #we seem to be re-creating a previously defined id... - #clear any existing caches for this id - puts stderr "punk::args::define Redefinition of id:$id - clearing existing data" - - #dict unset argdata_cache $prevraw ;#silently does nothing if key not present - dict for {k v} $argdata_cache { - if {[dict get $v id] eq $id} { - dict unset argdata_cache $k - } - } - dict for {k v} $rawdef_cache { - if {[dict get $v -id] eq $id} { - dict unset rawdef_cache $k - } - } - dict unset id_cache_rawdef $id - } - set is_dynamic [rawdef_is_dynamic $args] - set defspace [uplevel 1 {::namespace current}] - dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic -defspace $defspace] - dict set id_cache_rawdef $id $args - return $id - } - } - - proc idquery_info {id} { - variable id_cache_rawdef - variable rawdef_cache - if {[dict exists $id_cache_rawdef $id]} { - set sep [string repeat - 40] - set rawdef [dict get $id_cache_rawdef $id] - if {[dict exists $rawdef_cache $rawdef]} { - set idinfo [dict get $rawdef_cache $rawdef] - } else { - set idinfo "" - } - set result "raw definition:" - append result \n $sep - append result \n $rawdef - append result \n $sep - append result \n "id info:" - append result \n $idinfo - append result \n $sep - variable argdata_cache - #lsearch -stride not avail (or buggy) in some 8.6 interps - search manually for now (2025). todo - modernize some time after Tcl 9.0/9.1 more widespread.(2027?) - #check for and report if id is present multiple times - set argdata_records [list] - dict for {k v} $argdata_cache { - if {[dict get $v id] eq $id} { - if {$k eq $rawdef} { - lappend argdata_records [list 1 $k $v] - } else { - lappend argdata_records [list 0 $k $v] - } - } - } - append result \n "argdata cache:" - if {![llength $argdata_records]} { - append result \n "(not present)" - } else { - append result \n "present [llength $argdata_records] time(s)" - foreach r $argdata_records { - lassign $r match k v - if {$match} { - append result \n " - present with same rawdef key" - } else { - append result \n " - present with different rawdef key" - append result \n " [punk::lib::indent $k { }]" - } - } - if {[llength $argdata_records] > 1} { - append result \n "*more than one record was not expected - review*" - } - } - append result \n $sep - return $result - } - } - - proc define2 {args} { - dict get [resolve {*}$args] id - } - - proc resolve {args} { - variable rawdef_cache - variable id_cache_rawdef - set defspace "" - if {[dict exists $rawdef_cache $args]} { - set cinfo [dict get $rawdef_cache $args] - set id [dict get $cinfo -id] - set is_dynamic [dict get $cinfo -dynamic] - if {[dict exists $cinfo -defspace]} { - set defspace [dict get $cinfo -defspace] - } - } else { - #should we really be resolving something that hasn't been defined? - set id [rawdef_id $args] - puts stderr "Warning: punk::args::resolve called with undefined id:$id" - set is_dynamic [rawdef_is_dynamic $args] - dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] - dict set id_cache_rawdef $id $args - } - - - variable argdata_cache - variable argdefcache_unresolved - - - set cache_key $args - #ideally we would use a fast hash algorithm to produce a short key with low collision probability. - #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) - #review - check if there is a built-into-tcl way to do this quickly - #for now we will just key using the whole string - #performance seems ok - memory usage probably not ideal - #quote from DKF 2021 - #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. - #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. - #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. - #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). - #> If dealing with very large amounts of data, using a database is probably a good plan. - - set textargs $args - if {![llength $args]} { - punk::args::get_by_id ::punk::args::define {} - return - } - #if {[lindex $args 0] eq "-dynamic"} { - # set is_dynamic [lindex $args 1] - # set textargs [lrange $args 2 end] - #} - - #experimental - set LVL 2 - - if {!$is_dynamic} { - if {[tcl::dict::exists $argdata_cache $cache_key]} { - return [tcl::dict::get $argdata_cache $cache_key] - } - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - if {[string first \$\{ $optionspecs] > 0} { - if {$defspace ne ""} { - #normal/desired case - set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } else { - #todo - deprecate/stop from happening? - puts stderr "punk::args::resolve calling tstr for id:$id with no known definition space (-defspace empty)" - set optionspecs [uplevel $LVL [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } - } - } else { - - if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { - set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel $LVL [list ::subst $param]] - } - } else { - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - #dynamic - double substitution required. - #e.g - # set DYN_CHOICES {${[::somewhere::get_choice_list]}} - # set RED [punk::ansi::a+ bold red] - # set RST [punk::ansi::a] - # punk::args::define { - # -arg -choices {${$DYN_CHOICES}} -help "${$RED}important info${$RST}" - #} - if {$defspace ne ""} { - set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } - #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) - if {[string first \$\{ $optionspecs] > 0} { - set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel $LVL [list ::subst $param]] - } - tcl::dict::set argdefcache_unresolved $cache_key $pt_params - } - } - #argdata_cache should be limited in some fashion or will be a big memory leak??? - if {[tcl::dict::exists $argdata_cache [list $optionspecs]]} { - #resolved cache version exists - return [tcl::dict::get $argdata_cache [list $optionspecs]] - } - } - - - - #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices - #default to 1 for convenience - - #checks with no default - #-minsize -maxsize -range - - - #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi - #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist - - #set opt_defaults [tcl::dict::create] - #set val_defaults [tcl::dict::create] - - #set opt_solos [list] - #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end - - set records [list] - set linebuild "" - - set linelist [split $optionspecs \n] - set lastindent "" - foreach ln $linelist { - if {[tcl::string::trim $ln] eq ""} {continue} - regexp {(\s*).*} $ln _all lastindent - break ;#break at first non-empty - } - #puts "indent1:[ansistring VIEW $lastindent]" - set in_record 0 - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - foreach rawline $linelist { - set recordsofar [tcl::string::cat $linebuild $rawline] - #ansi colours can stop info complete from working (contain square brackets) - #review - when exactly are ansi codes allowed/expected in record lines. - # - we might reasonably expect them in default values or choices or help strings - # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. - # - eg set line "set x \"a[a+ red]red[a]\"" - # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket - if {$has_punkansi} { - set test_complete [punk::ansi::ansistrip $recordsofar] - } else { - #review - #we only need to strip enough to stop interference with 'info complete' - set test_complete [string map [list \x1b\[ ""] $recordsofar] - } - if {![tcl::info::complete $test_complete]} { - #append linebuild [string trimleft $rawline] \n - if {$in_record} { - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. - #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. - #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. - #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) - #(note string first "" $str is fast and returns -1) - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline \n - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline \n - } else { - append linebuild $rawline \n - } - } else { - set in_record 1 - regexp {(\s*).*} $rawline _all lastindent - #puts "indent: [ansistring VIEW -lf 1 $lastindent]" - #puts "indent from rawline:$rawline " - append linebuild $rawline \n - } - } else { - set in_record 0 - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline - } else { - append linebuild $rawline - } - lappend records $linebuild - set linebuild "" - } - } - set cmd_info {} - set package_info {} - set id_info {} ;#e.g -children ?? - set doc_info {} - #set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table - set seealso_info {} - set keywords_info {} - ###set leader_min 0 - ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit - #set leader_max "" - #(common case of no leaders specified) - #set opt_any 0 - #set val_min 0 - #set val_max -1 ;#-1 for no limit - set DEF_definition_id $id - - #form_defs - set F [dict create _default [New_command_form _default]] - set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under - - #set ARGSPACE [dict create] ;#keyed on form - #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values - - set refs [dict create] - set record_type "" - set record_number -1 ;# - foreach rec $records { - set trimrec [tcl::string::trim $rec] - switch -- [tcl::string::index $trimrec 0] { - "" - # {continue} - } - incr record_number - set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict - if {[llength $record_values] % 2 != 0} { - #todo - avoid raising an error - store invalid defs keyed on id - error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" - } - # ---------------------------------------------------------- - # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. - #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! - #(form_ids_active is otherwise set in the @form handling block) - - #consider the following 2 line entry which is potentially dynamically included via a tstr: - # @form -form {* newform} - # @form -form {newform} -synopsis "cmd help ?stuff?" - #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. - #(because _default is usually 'taken over' by the first encountered form id) - #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record - #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. - - if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { - set patterns [dict get $record_values -form] - set record_form_ids [list] - foreach p $patterns { - if {[regexp {[*?\[\]]} $p]} { - #isglob - only used for matching existing forms - lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] - } else { - #don't test for existence - will define new form if necessary - lappend record_form_ids $p - } - } - #-form values could be globs that didn't match. record_form_ids could be empty.. - if {[llength $record_form_ids]} { - #only rename _default if it's the sole entry - if {[dict size $F] == 1 && [dict exists $F "_default"]} { - if {"_default" ni $record_form_ids} { - #only initial form exists - but we are mentioning new ones - #first rename the _default to first encountered new form id - #(just replace whole dict with new key - same data) - set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] - #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F - #we are only setting active because of the rename - @form is the way to change active forms list - set form_ids_active [lindex $record_form_ids 0] - } - } - foreach fid $record_form_ids { - if {![dict exists $F $fid]} { - if {$firstword eq "@form"} { - #only @form directly supplies keys - dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] - } else { - dict set F $fid [New_command_form $fid] - } - } else { - #update form with current record opts, except -form - if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } - } - } - } - } else { - #missing or empty -form - set record_form_ids $form_ids_active - if {$firstword eq "@form"} { - foreach fid $form_ids_active { - dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] - } - } - } - # ---------------------------------------------------------- - - set firstchar [tcl::string::index $firstword 0] - set secondchar [tcl::string::index $firstword 1] - if {$firstchar eq "@" && $secondchar ne "@"} { - set record_type "directive" - set directive_name $firstword - set at_specs $record_values - - switch -- [tcl::string::range $directive_name 1 end] { - dynamic { - set is_dynamic 1 - } - id { - #disallow duplicate @id line ? - #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) - - #id An id will be allocated if no id line present or the -id value is "auto" - - if {[dict exists $at_specs -id]} { - set thisid [dict get $at_specs -id] - if {$thisid ni [list $id auto]} { - error "punk::args::define @id mismatch existing: $id vs $thisid" - } - } - set id_info $at_specs - } - ref { - #a reference within the definition - #e.g see punk::args::tclcore ::after - #global reference dict - independent of forms - #ignore refs without an -id - #store all keys except -id - #complete overwrite if refid repeated later on - if {[dict exists $at_specs -id]} { - dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] - } - } - default { - #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple - #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) - #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) - #That is possibly too complicated and/or unnecessary? - #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? - - if {[dict exists $at_specs -id]} { - set copyfrom [get_spec [dict get $at_specs -id]] - #we don't copy the @id info from the source - #for now we only copy across if nothing set.. - #todo - bring across defaults for empty keys at targets? - #need to keep it simple enough to reason about behaviour easily.. - if {[dict size $copyfrom]} { - if {![dict size $cmd_info]} { - set cmd_info [dict get $copyfrom cmd_info] - } - if {![dict size $doc_info]} { - set doc_info [dict get $copyfrom doc_info] - } - - #foreach fid $record_form_ids { - # #only use elements with matching form id? - # #probably this feature mainly useful for _default anyway so that should be ok - # #cooperative doc sets specified in same file could share via known form ids too - # FORMDISPLAY has keys -header -body - # if {![dict size $F $fid $FORMDISPLAY]} { - # if {[dict exists $copyfrom FORMS $fid FORMDISPLAY]} { - # dict set F $fid FORMDISPLAY [dict get $copyfrom FORMS $fid FORMDISPLAY] - # } - # } - # #TODO - # #create leaders opts vals depending on position of @default line? - # #options on @default line to exclude/include sets??? - #} - } - } - } - form { - # arity system ? - #handle multiple parsing styles based on arities and keyword positions (and/or flags?) - #e.g see lseq manual with 3 different parsing styles. - #aim to produce a table/subtable for each - # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ - # -arities { - # 2 - # {3 anykeys {1 .. 1 to}} - # {4 anykeys {3 by}} - # {5 anykeys {1 .. 1 to 3 by}} - # }\ - # -fallback 1 - # ... - # @parser -synopsis "start 'count' count ??'by'? step?"\ - # -arities { - # {3 anykeys {1 count}} - # } - # ... - # @form -synopsis "count ?'by' step?"\ - # -arities { - # 1 - # {3 anykeys {1 by}} - # } - # - # see also after manual - # @form -arities {1} - # @form -arities { - # 1 anykeys {0 info} - # } - #todo - - #can we generate a form synopsis if -synopsis not supplied? - - #form id can be list of ints|names?, or * - if {[dict exists $at_specs -form]} { - set idlist [dict get $at_specs -form] - if {$idlist eq "*"} { - #* only applies to form ids that exist at the time - set idlist [dict keys $F] - } - set form_ids_active $idlist - } - #new form keys already created if they were needed (done for all records that have -form ) - } - package { - set package_info [dict merge $package_info $at_specs] - } - cmd { - #allow arbitrary - review - set cmd_info [dict merge $cmd_info $at_specs] - } - doc { - set doc_info [dict merge $doc_info $at_specs] - } - formdisplay { - #override the displayed argument table for the form. - #(formdisplay keys -header -body) - #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing - foreach fid $record_form_ids { - tcl::dict::set F $fid FORMDISPLAY [dict merge [tcl::dict::get $F $fid FORMDISPLAY] $at_specs] - } - } - opts { - foreach fid $record_form_ids { - if {[tcl::dict::get $F $fid argspace] eq "values"} { - error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" - } - tcl::dict::set F $fid argspace "options" - set tmp_optspec_defaults [dict get $F $fid OPTSPEC_DEFAULTS] - - foreach {k v} $at_specs { - switch -- $k { - -form { - #review - handled above - } - -any - - -anyopts { - #set opt_any $v - tcl::dict::set F $fid OPT_ANY $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { - #review - only apply to certain types? - tcl::dict::set tmp_optspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_optspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - index { - set v indexexpression - } - none - "" - - - any - ansistring - globstring - list { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_optspec_defaults -type $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple - - -prefix { - #allow overriding of defaults for options that occur later - tcl::dict::set tmp_optspec_defaults $k $v - } - default { - set known { -any -form -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" - } - } - } - tcl::dict::set F $fid OPTSPEC_DEFAULTS $tmp_optspec_defaults - } ;# end foreach record_form_ids - } - leaders { - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] in [list options values]} { - error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" - } - set tmp_leaderspec_defaults [dict get $F $fid LEADERSPEC_DEFAULTS] - - foreach {k v} $at_specs { - switch -- $k { - -form { - #review - handled above - } - -min - - -minvalues { - if {$v < 0} { - error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MIN $v - #if {$leader_max == 0} { - # set leader_max -1 - #} - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MAX $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -choiceinfo { - if {[llength $v] %2 != 0} { - error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - #-choicegroups? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_leaderspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - index { - set v indexexpression - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -ensembleparameter { - #review - tcl::dict::set tmp_leaderspec_defaults $k $v - #error "punk::args::define - -ensembleparameter not supported as a default for @leaders - only valid on actual leader arguments" - } - default { - set known { -min -form -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid LEADERSPEC_DEFAULTS $tmp_leaderspec_defaults - - } ;#end foreach record_form_ids - - } - values { - foreach fid $record_form_ids { - dict set F $fid argspace "values" - - set tmp_valspec_defaults [dict get $F $fid VALSPEC_DEFAULTS] - - foreach {k v} $at_specs { - switch -- $k { - -form { - #review - handled above - } - -min - - -minvalues { - if {$v < 0} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" - } - #set val_min $v - dict set F $fid VAL_MIN $v - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" - } - #set val_max $v - dict set F $fid VAL_MAX $v - } - -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_valspec_defaults $k $v - } - -choiceinfo - -choicegroups { - if {[llength $v] % 2 != 0} { - error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - # -choicegroups ?? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_valspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - index { - set v indexexpression - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set tmp_valspec_defaults $k $v - } - default { - set known { -min -form -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid VALSPEC_DEFAULTS $tmp_valspec_defaults - } - - } - seealso { - #todo! - #like @doc, except displays in footer, multiple - sub-table? - set seealso_info [dict merge $seealso_info $at_specs] - } - keywords { - #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? - set keywords_info [dict merge $keywords_info $at_specs] - } - default { - error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @formdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" - } - } - #record_type directive - continue - } elseif {$firstchar eq "-"} { - set argname $firstword - set argdef_values $record_values - tcl::dict::set argdef_values -ARGTYPE option - - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - dict set F $fid argspace "options" - } elseif {[dict get $F $fid argspace] eq "values"} { - error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" - } - set record_type option - dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] - #lappend opt_names $argname - } - - set is_opt 1 - } else { - set argname $firstword - if {$firstchar eq "@"} { - #allow basic @@ escaping for literal argname that begins with @ - set argname [tcl::string::range $argname 1 end] - } - - set argdef_values $record_values - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - set record_type leader - tcl::dict::set argdef_values -ARGTYPE leader - #lappend leader_names $argname - set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] - if {$argname ni $temp_leadernames} { - lappend temp_leadernames $argname - tcl::dict::set F $fid LEADER_NAMES $temp_leadernames - } else { - #This can happen if the definition has repeated values - error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" - } - - if {[dict get $F $fid LEADER_MAX] >= 0} { - if {[dict get $F $fid LEADER_MAX] < [llength $temp_leadernames]} { - puts stderr "punk::args::resolve warning arg $argname LEADER_MAX == [dict get $F $fid LEADER_MAX] but [llength $temp_leadernames] leader names found @id:$DEF_definition_id" - dict set F $fid LEADER_MAX [llength $temp_leadernames] - } - } - } else { - set record_type value - tcl::dict::set argdef_values -ARGTYPE value - set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] - if {$argname ni $temp_valnames} { - lappend temp_valnames $argname - tcl::dict::set F $fid VAL_NAMES $temp_valnames - } else { - error "punk::args::define - arg $argname already present as value in '$rec' (command form:'$fid') @id:$DEF_definition_id" - } - #lappend val_names $argname - if {[dict get $F $fid VAL_MAX] >= 0} { - if {[dict get $F $fid VAL_MAX] < [llength $temp_valnames]} { - puts stderr "punk::args::resolve warning arg $argname VAL_MAX == [dict get $F $fid VAL_MAX] but [llength $temp_valnames] value names found @id:$DEF_definition_id" - dict set F $fid VAL_MAX [llength $temp_valnames] - } - } - } - } - - set is_opt 0 - } - - - #assert - we only get here if it is a value or flag specification line. - #assert argdef_values has been set to the value of record_values - - foreach fid $record_form_ids { - if {$is_opt} { - set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS] - } else { - if {[dict get $F $fid argspace] eq "values"} { - set spec_merged [dict get $F $fid VALSPEC_DEFAULTS] - } else { - set spec_merged [dict get $F $fid LEADERSPEC_DEFAULTS] - } - } - - # -> argopt argval - foreach {spec specval} $argdef_values { - #literal-key switch - bytecompiled to jumpTable - switch -- $spec { - -form { - - } - -type { - #normalize here so we don't have to test during actual args parsing in main function - switch -- [tcl::string::tolower $specval] { - int - integer { - tcl::dict::set spec_merged -type int - } - bool - boolean { - tcl::dict::set spec_merged -type bool - } - char - character { - tcl::dict::set spec_merged -type char - } - dict - dictionary { - tcl::dict::set spec_merged -type dict - } - index - indexexpression { - tcl::dict::set spec_merged -type indexexpression - } - "" - none { - if {$is_opt} { - tcl::dict::set spec_merged -type none - 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. - } - } else { - #-solo only valid for flags - error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" - } - } - any - anything { - tcl::dict::set spec_merged -type any - } - ansi - ansistring { - tcl::dict::set spec_merged -type ansistring - } - any - string - globstring { - tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - } - literal { - #value is the name of the argument - if {$is_opt} { - error "punk::args::define - invalid -type 'literal' for flag argument '$argname' @id:$DEF_definition_id" - } - tcl::dict::set spec_merged -type literal - } - default { - #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW - tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - } - } - } - -default - -solo - -range - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo - - -minsize - -maxsize - -nocase - -optional - -multiple - - -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - - -regexprepass - -regexprefail - -regexprefailmsg - { - #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines - #review -solo 1 vs -type none ? conflicting values? - tcl::dict::set spec_merged $spec $specval - } - -ensembleparameter { - #review - only leaders? - tcl::dict::set spec_merged $spec $specval - } - -prefix { - #for flags/options - tcl::dict::set spec_merged $spec $specval - } - -validationtransform { - #string is dict only 8.7/9+ - if {[llength $specval] % 2} { - error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" - } - dict for {tk tv} $specval { - switch -- $tk { - -function - -type - -minsize - -maxsize - -range { - } - default { - set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? - error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" - } - } - } - - } - default { - if {[string match ref-* $spec]} { - #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) - #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. - if {![tcl::dict::exists $refs $specval]} { - puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" - } else { - set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" - if {$targetswitch eq "-*"} { - set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id - } else { - if {[tcl::dict::exists $refs $specval $targetswitch]} { - tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] - } else { - puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" - } - } - } - } else { - set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - -ensembleparameter\ - ] - error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" - } - } - } - } ;# end foreach {spec specval} argdef_values - - - if {$is_opt} { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - if {[tcl::dict::get $spec_merged -type] eq "none"} { - #JJJJ - dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname] - } - } else { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - tcl::dict::set F $fid ARG_INFO $argname $spec_merged - #review existence of -default overriding -optional - if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { - if {$is_opt} { - set temp_opt_required [dict get $F $fid OPT_REQUIRED] - lappend temp_opt_required $argname - dict set F $fid OPT_REQUIRED $temp_opt_required - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - set temp_leader_required [dict get $F $fid LEADER_REQUIRED] - lappend temp_leader_required $argname - dict set F $fid LEADER_REQUIRED $temp_leader_required - } else { - set temp_val_required [dict get $F $fid VAL_REQUIRED] - lappend temp_val_required $argname - dict set F $fid VAL_REQUIRED $temp_val_required - } - } - } - if {[tcl::dict::exists $spec_merged -default]} { - if {$is_opt} { - #tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] - tcl::dict::set F $fid OPT_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } else { - #tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] - tcl::dict::set F $fid VAL_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } - } - } - } ;# end foreach fid record_form_ids - - } ;# end foreach rec $records - - - #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { - # variable id_counter - # set DEF_definition_id "autoid_[incr id_counter]" - #} - - - #now cycle through ALL forms not just form_ids_active (record_form_ids) - dict for {fid formdata} $F { - # REVIEW - #no values specified - we can allow last leader to be multiple - foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { - error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" - } - } - - #todo - disallow any -multiple == true entries if any leaders have -multiple == true? - #(creates parsing ambiguity) - #ambiguity could be resolved if at least one required option/flag eg -- - #ambiguities could theoretically also be resolved with required literals or choices - or even based on argument type - #(overcomplex? todo see if any core/tcllib commands work like that) - - #only allow a single entry within VAL_NAMES to have -multiple == true - #example of command with non-trailing -multiple == true is core command: 'file copy ?-force? ?--? source ?source?... targetDir - set val_multiples 0 - foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { - if {$val_multiples > 0} { - error "bad setting -multiple true on argument spec for value '$valname' in command form:'$fid'. Only a single value argument specification can be marked with -multiple true @id:$DEF_definition_id" - } - incr val_multiples - } - } - - #todo - document that ambiguities in API are likely if both @leaders and @values used - #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) - - - dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata LEADERSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata OPTSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata VALSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - - - - - #todo - precalculate a set of 'arity' entries for each form - #We want a structure for the arg parser to get easy access and make a fast decision on which form applies - #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? - #1) after ms (1 1) - #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? - #3) after cancel id (2 2) - #4) after cancel script ?script...? (2 -1) - #5) after idle script ?script...? (1 -1) - #6) after info ?id? (1 2) - - #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) - - #in the above case we have no unique total_arity - #we would also want to consider values when selecting - #e.g given the invalid command "after cancel" - # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. - - - - set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands - #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use - #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form - #e.g commandline completion could show list of synopsis entries to select from - - set form_info [dict create] - dict for {fid fdict} $F { - dict set form_info $fid {} - dict for {optk optv} $fdict { - if {[string match -* $optk]} { - dict set form_info $fid $optk $optv - } - } - } - - set argdata_dict [tcl::dict::create\ - id $DEF_definition_id\ - cmd_info $cmd_info\ - doc_info $doc_info\ - package_info $package_info\ - seealso_info $seealso_info\ - id_info $id_info\ - FORMS $F\ - form_names [dict keys $F]\ - form_info $form_info\ - ] - - tcl::dict::set argdata_cache $cache_key $argdata_dict - if {$is_dynamic} { - #also cache resolved version - tcl::dict::set argdata_cache [list $optionspecs] $argdata_dict - } - - #tcl::dict::set id_cache_rawdef $DEF_definition_id $args - #puts "xxx:$result" - return $argdata_dict - } - - #return raw definition list as created with 'define' - # - possibly with unresolved dynamic parts - proc raw_def {id} { - variable id_cache_rawdef - set realid [real_id $id] - if {![dict exists $id_cache_rawdef $realid]} { - return "" - } - return [tcl::dict::get $id_cache_rawdef $realid] - } - - - namespace eval argdoc { - variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @formdisplay @seealso @leaders @opts @values leaders opts values} - variable resolved_def_TYPE_CHOICEGROUPS { - directives {@id @package @cmd @ref @doc @formdisplay @seealso} - argumenttypes {leaders opts values} - remaining_defaults {@leaders @opts @values} - } - - lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { - @id -id ::punk::args::resolved_def - @cmd -name punk::args::resolved_def -help\ - "Resolves or retrieves the previously resolved definition and - uses the 'spec' form to build a response in definition format. - - Pulling argument definition data from another function is a form - of tight coupling to the other function that should be done with - care. - - Note that the directives @leaders @opts @values may appear multiple - times in a source definition - applying defaults for arguments that - follow. When retrieving these - there is only a single result for - each that represents the defaults after all have been applied. - When retrieving -types * each of these will be positioned before - the arguments of that type - but this doesn't mean there was a single - leading directive for this argument type in the source definition. - Each argument has already had its complete specification recorded in - its own result. - - When manually specifying -types, the order @leaders then @opts then - @values must be maintained - but if they are placed before their - corresponding arguments, they will not affect the retrieved arguments - as these arguments are already fully spec'd. The defaults from the - source can be removed by adding @leaders, @opts @values to the - -antiglobs list, but again - this won't affect the existing arguments. - Each argument can have members of its spec overridden using the - -override dictionary. - " - @leaders -min 0 -max 0 - @opts - -return -default text -choices {text dict} - -form -default 0 -help\ - "Ordinal index or name of command form" - - #no restriction on number of types/repetitions? - -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} - -antiglobs -default {} -type list -help\ - "Glob patterns for directive or argument/flags to - be suppressed" - -override -type dict -optional 1 -default "" -help\ - "dict of dicts. Key in outer dict is the name of a - directive or an argument. Inner dict is a map of - overrides/additions (- ...) for that line. - " - @values -min 1 -max -1 - id -type string -help\ - "identifer for a punk::args definition - This will usually be a fully-qualifed - path for a command name" - pattern -type string -optional 1 -default * -multiple 1 -help\ - "glob-style patterns for retrieving value or switch - definitions. - - If -type is * and pattern is * the entire definition including - directive lines will be returned in line form. - (directives are lines beginning with - @ e.g @id, @cmd etc) - - if -type is leaders,opts or values matches from that type - will be returned. - - if -type is another directive such as @id, @doc etc the - patterns are ignored. - - " - }]] - } - - - proc resolved_def {args} { - #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. - set opts [dict create\ - -return text\ - -types {}\ - -form 0\ - -antiglobs {}\ - -override {}\ - ] - if {[llength $args] < 1} { - #must have at least id - punk::args::parse $args withid ::punk::args::resolved_def - return - } - set patterns [list] - - #a definition id must not begin with "-" ??? review - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {$a in {-type -types}} { - incr i - dict set opts -types [lindex $args $i] - } elseif {[string match -* $a]} { - incr i - dict set opts $a [lindex $args $i] - } else { - set id [lindex $args $i] - set patterns [lrange $args $i+1 end] - break - } - if {$i == [llength $args]-1} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - if {![llength $patterns]} { - set patterns [list *] - } - dict for {k v} $opts { - switch -- $k { - -return - -form - -types - -antiglobs - -override {} - default { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - } - set typelist [dict get $opts -types] - if {[llength $typelist] == 0} { - set typelist {*} - } - foreach type $typelist { - if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - - - variable id_cache_rawdef - set realid [real_id $id] - if {$realid eq ""} { - return - } - - set deflist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] - - set opt_form [dict get $opts -form] - if {[string is integer -strict $opt_form]} { - set formname [lindex [dict get $specdict form_names] $opt_form] - } else { - set formname $opt_form - } - set opt_override [dict get $opts -override] - set opt_return [dict get $opts -return] - - #set arg_info [dict get $specdict ARG_INFO] - set arg_info [dict get $specdict FORMS $formname ARG_INFO] - set argtypes [dict create leaders leader opts option values value] - - set opt_antiglobs [dict get $opts -antiglobs] - set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] - set suppressed_directives [list] - set suppressed_args [list] - foreach ag $opt_antiglobs { - foreach d $directives { - if {[string match $ag $d]} { - lappend suppressed_directives $d - } - } - foreach argname [dict keys $arg_info] { - if {[string match $ag $argname]} { - lappend suppressed_args $argname - } - } - } - set suppressed_directives [lsort -unique $suppressed_directives] - set suppressed_args [lsort -unique $suppressed_args] - - set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] - - set globbed [list] - foreach pat $patterns { - set matches [dict keys $arg_info $pat] - lappend globbed {*}$matches - } - set globbed [lsort -unique $globbed] - #maintain order of original arg_info keys in globbed results - set ordered_globbed [list] - foreach a [dict keys $arg_info] { - if {$a ni $ordered_globbed && $a in $globbed} { - lappend ordered_globbed $a - } - } - set included_args [punk::args::system::punklib_ldiff $ordered_globbed $suppressed_args] - - set result "" - set resultdict [dict create] - foreach type $typelist { - switch -exact -- $type { - * { - if {"@id" in $included_directives} { - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - foreach directive {@package @cmd @doc @seealso} { - set dshort [string range $directive 1 end] - if {"$directive" in $included_directives} { - if {[dict exists $opt_override $directive]} { - append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict ${dshort}_info]" - dict set resultdict $directive [dict get $specdict ${dshort}_info] - } - } - } - - #todo @formdisplay - - - #output ordered by leader, option, value - foreach pseudodirective {leaders opts values} tp {leader option value} { - set directive "@$pseudodirective" - switch -- $directive { - @leaders {set defaults_key LEADERSPEC_DEFAULTS} - @opts {set defaults_key OPTSPEC_DEFAULTS} - @values {set defaults_key VALSPEC_DEFAULTS} - } - - if {"$directive" in $included_directives} { - if {[dict exists $opt_override "$directive"]} { - append result \n "$directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict FORMS $formname $defaults_key]" - dict set resultdict $directive [dict get $specdict FORMS $formname $defaults_key] - } - } - - if {$pseudodirective in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq $tp} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "$m $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - - } - @id { - if {"@id" in $included_directives} { - #only a single id record can exist - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - } - @package - @cmd - @doc - @seealso { - if {"$type" in $included_directives} { - set tp [string range $type 1 end] ;# @package -> package - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict ${tp}_info]" - dict set resultdict $type [dict get $specdict ${tp}_info] - } - } - #todo @formdisplay - } - @leaders - @opts - @values { - #these are the active defaults for further arguments - if {"$type" in $included_directives} { - switch -- $type { - @leaders {set defaults_key LEADERSPEC_DEFAULTS} - @opts {set defaults_key OPTSPEC_DEFAULTS} - @values {set defaults_key VALSPEC_DEFAULTS} - } - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS]" - dict set resultdict $type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] - } - } - } - leaders - opts - values { - #pseudo-directives - if {$type in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "$m $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - default { - } - } - if {$opt_return eq "text"} { - return $result - } else { - return $resultdict - } - } - } - - proc resolved_def_values {id {patternlist *}} { - variable id_cache_rawdef - set realid [real_id $id] - if {$realid ne ""} { - set deflist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [resolve {*}$deflist] - set arg_info [dict get $specdict ARG_INFO] - set valnames [dict get $specdict VAL_NAMES] - set result "" - if {$patternlist eq "*"} { - foreach v $valnames { - set def [dict get $arg_info $v] - set def [dict remove $def -ARGTYPE] - append result \n "$v $def" - } - return $result - } else { - foreach pat $patternlist { - set matches [dict keys $arg_info $pat] - set matches [lsearch -all -inline -glob $valnames $pat] - foreach m $matches { - set def [dict get $arg_info $m] - set def [dict remove $def -ARGTYPE] - append result \n "$m $def" - } - } - return $result - } - } - } - #proc resolved_def_leaders ?? - #proc resolved_def_opts ?? - - proc get_spec {id} { - set deflist [raw_def $id] - if {$deflist eq ""} { - return - } - return [resolve {*}$deflist] - #if {[id_exists $id]} { - # return [resolve {*}[raw_def $id]] - #} - } - proc is_dynamic {id} { - variable id_cache_rawdef - variable rawdef_cache - set deflist [raw_def $id] - if {[dict exists $rawdef_cache $deflist -dynamic]} { - return [dict get $rawdef_cache $deflist -dynamic] - } - return [rawdef_is_dynamic $deflist] - #@dynamic only has meaning as 1st element of a def in the deflist - } - - #@id must be within first 4 lines of a block - or assign auto - #review - @dynamic block where -id not explicitly set? - disallow? - proc rawdef_id {rawdef} { - set id "" - foreach d $rawdef { - foreach ln [lrange [split $d \n] 0 4] { - if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { - if {$firstword eq "@id"} { - if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { - set id [dict get $rest -id] - break - } - } - } - } - if {$id ne ""} { - break - } - } - if {$id eq "" || [string tolower $id] eq "auto"} { - variable id_counter - set id "autoid_[incr id_counter]" - } - #puts "==>id: $id" - return $id - } - #test the rawdef for @dynamic directive - proc rawdef_is_dynamic {rawdef} { - #temporary - old way - set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] - if {$flagged_dynamic} { - return true - } - foreach d $rawdef { - if {[regexp {\s*(\S+)} $d _match firstword]} { - if {$firstword eq "@dynamic"} { - return true - } - } - } - return false - } - - variable aliases - set aliases [dict create] - - lappend PUNKARGS [list { - @id -id ::punk::args::get_ids - @cmd -name punk::args::get_ids -help\ - "return list of ids for argument definitions" - @values -min 0 -max 1 - match -default * -help\ - "exact id or glob pattern for ids" - }] - proc get_ids {{match *}} { - variable id_cache_rawdef - variable aliases - return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] - } - - #we don't automatically test for (autodef)$id - only direct ids and aliases - proc id_exists {id} { - variable aliases - if {[tcl::dict::exists $aliases $id]} { - return 1 - } - variable id_cache_rawdef - tcl::dict::exists $id_cache_rawdef $id - } - proc set_alias {alias id} { - variable aliases - dict set aliases $alias $id - } - proc unset_alias {alias} { - variable aliases - dict unset aliases $alias - } - proc get_alias {alias} { - variable aliases - if {[dict exists $aliases $alias]} { - return [tcl::dict::get $aliases $alias] - } - } - - proc real_id {id} { - variable id_cache_rawdef - variable aliases - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } else { - set check_updates [list [namespace qualifiers $id]] - #puts stderr "---->real_id '$id' update_definitions $check_updates" - if {![llength [update_definitions $check_updates]]} { - #nothing new loaded - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } else { - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } - } - } - - proc status {} { - upvar ::punk::args::register::NAMESPACES registered - upvar ::punk::args::register::loaded_packages loaded_packages - upvar ::punk::args::register::loaded_info loaded_info - upvar ::punk::args::register::scanned_packages scanned_packages - upvar ::punk::args::register::scanned_info scanned_info - set result "" - # [format %-${w0}s $idtail] - set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] - append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n - set width_c2 [string length "Scanned_ids"] - set width_c3 [string length "Scantime_us"] - set width_c4 [string length "Loaded_defs"] - set width_c5 [string length "Loadtime_us"] - set count_unloaded 0 - set count_loaded 0 - foreach ns $registered { - if {$ns in $scanned_packages} { - set ids [dict get $scanned_info $ns idcount] - set scan_us [dict get $scanned_info $ns time] - } else { - set ids "" - set scan_us "" - } - if {$ns in $loaded_packages} { - incr count_loaded - set ldefs [dict get $loaded_info $ns defcount] - set load_us [dict get $loaded_info $ns time] - } else { - incr count_unloaded - set ldefs "" - set load_us "" - } - append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n - } - append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" - return $result - } - - #scanned_packages (list) - #namespace_docpackages (dict) - proc update_definitions {{nslist *}} { - #puts "----> update_definitions '$nslist'" - if {[set gposn [lsearch $nslist {}]] >= 0} { - lset nslist $gposn :: - } - upvar ::punk::args::register::NAMESPACES registered ;#list - upvar ::punk::args::register::loaded_packages loaded_packages ;#list - upvar ::punk::args::register::loaded_info loaded_info ;#dict - upvar ::punk::args::register::scanned_packages scanned_packages ;#list - upvar ::punk::args::register::scanned_info scanned_info ;#dict - upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict - - - #puts stderr "-->update_definitions '$nslist'" - #needs to run quickly - especially when no package namespaces to be scanned for argdefs - #e.g - gets called for each subcommand of an ensemble (could be many) - # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. - #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. - # -- --- --- --- --- --- - # common-case fast-path - - if {[llength $loaded_packages] == [llength $registered]} { - #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. - #assert - if all are registered - then all have been scanned - return {} - } - # -- --- --- --- --- --- - - set unscanned [punklib_ldiff $registered $scanned_packages] - if {[llength $unscanned]} { - foreach pkgns $unscanned { - set idcount 0 - set ts_start [clock microseconds] - if {[info exists ${pkgns}::PUNKARGS]} { - set seen_documentedns [list] ;#seen per pkgns - foreach definitionlist [set ${pkgns}::PUNKARGS] { - #namespace eval $evalns [list punk::args::define {*}$definitionlist] - set id [rawdef_id $definitionlist] - if {[string match autoid_* $id]} { - puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" - puts stderr "definition:\n" - foreach d $definitionlist { - set out "" - foreach ln [split $d \n] { - append out " " $ln \n - } - puts $out - } - continue - } - #todo - detect duplicate ids (last will silently win.. should be reported somewhere) - incr idcount - set documentedns [namespace qualifiers $id] - if {$documentedns eq ""} {set documentedns ::} - if {$documentedns ni $seen_documentedns} { - #don't add own ns as a key in namespace_docpackages - if {$documentedns ne $pkgns} { - dict lappend namespace_docpackages $documentedns $pkgns - } - lappend seen_documentedns $documentedns - } - } - } - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - dict set scanned_info $pkgns [dict create time $diff idcount $idcount] - #we count it as scanned even if PUNKARGS didn't exist - #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) - lappend scanned_packages $pkgns - } - } - - - - if {"*" in $nslist} { - set needed [punklib_ldiff $registered $loaded_packages] - } else { - set needed [list] - foreach pkgns $nslist { - if {![string match ::* $pkgns]} { - puts stderr "warning: update_definitions received unqualified ns: $pkgns" - set pkgns ::$pkgns - } - if {$pkgns in $registered && $pkgns ni $loaded_packages} { - lappend needed $pkgns - } - #argdoc sub namespace is a standard place to put defs that match the namespace below - #(generally the PUNKARGS in a namespace should apply to own ns) - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { - lappend needed $docns - } - } - if {[dict exists $namespace_docpackages $pkgns]} { - #this namespace has other argdef sources - foreach docns [dict get $namespace_docpackages $pkgns] { - if {$docns ni $loaded_packages} { - lappend needed $docns - } - } - } - } - } - - - - set newloaded [list] - foreach pkgns $needed { - #puts stderr "update_definitions Loading: $pkgns" - set ts_start [clock microseconds] - set def_count 0 - if {![catch { - if {[info exists ${pkgns}::PUNKARGS]} { - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - namespace eval ${pkgns}::argdoc { - set epath [namespace path] - set pkgns [namespace parent] - if {$pkgns ni $epath} { - namespace path [list {*}$epath $pkgns] ;#add to tail - } - - } - set evalns $docns - } else { - set evalns $pkgns - } - foreach definitionlist [set ${pkgns}::PUNKARGS] { - namespace eval $evalns [list punk::args::define {*}$definitionlist] - incr def_count - } - } - - #process list of 2-element lists - if {[info exists ${pkgns}::PUNKARGS_aliases]} { - foreach adef [set ${pkgns}::PUNKARGS_aliases] { - punk::args::set_alias {*}$adef - } - } - } errMsg]} { - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - lappend loaded_packages $pkgns - lappend newloaded $pkgns - dict set loaded_info $pkgns [dict create time $diff defcount $def_count] - } else { - puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" - } - } - return $newloaded - } - - #for use within get_dict only - #This mechanism gets less-than-useful results for oo methods - #e.g {$obj} - proc Get_caller {} { - #set call_level -3 ;#for get_dict call - set call_level -4 - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - #puts "-->$cmdinfo" - #puts "-->[tcl::info::frame -3]" - while {[string last \n $cmdinfo] >= 1} { - #looks like a script - haven't gone up far enough? - #(e.g patternpunk oo system: >punk . poses -invalidoption) - incr call_level -1 - if {[catch { - set nextup [tcl::info::frame $call_level] - } ]} { - break - } - set cmdinfo [tcl::dict::get $nextup cmd] - set caller [regexp -inline {\S+} $cmdinfo] - if {[interp alias {} $caller] ne ""} { - #puts "found alias for caller $caller to [interp alias {} $caller]" - #see if we can go further - incr call_level -1 - if {[catch { - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - } errM ]} { - puts "err: $errM" - break - } - } - } - set caller [regexp -inline {\S+} $cmdinfo] - if {$caller eq "namespace"} { - # review - message? - set cmdinfo "Get_caller (punk::args::get_dict?) called from namespace" - } - return $cmdinfo - } - - - # -------------------------------------- - #test of Get_caller - lappend PUNKARGS [list { - @id -id ::punk::args::test1 - @values -min 0 -max 0 - }] - proc test_get_dict {args} { - punk::args::get_dict [punk::args::raw_def ::punk::args::test1] $args - } - proc test_get_by_id {args} { - punk::args::get_by_id ::punk::args::test1 $args - } - #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. - proc test_callers {args} { - if {![llength $args]} { - puts "these test functions accept no arguments" - puts "Call with arg(s) to compare error output" - } - - if {[catch {test_get_dict {*}$args} errM]} { - puts $errM - } - puts "------------" - if {[catch {test_get_by_id {*}$args} errM]} { - puts $errM - } - return done - } - # -------------------------------------- - - set map "" - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::arg_error - @cmd -name punk::args::arg_error -help\ - "Generates a table (by default) of usage information for a command. - A trie system is used to create highlighted prefixes for command - switches and for subcommands or argument/switch values that accept - a defined set of choices. These prefixes match the mechanism used - to validate arguments (based on tcl::prefix::match). - - This function is called during the argument parsing process - (if the definition is not only being used for documentation) - It is also called by punk::args::usage which is in turn - called by the punk::ns introspection facilities which creates - on the fly definitions for some commands such as ensembles and - oo objects where a manually defined one isn't present. - " - @leaders -min 2 -max 2 - msg -type string -help\ - "Error message to display immediately prior to usage table. - May be empty string to just display usage. - " - spec_dict -type dict -help\ - "Dictionary of argument specifications. - This is the internal format parsed from - the textual definition. It contains the data - organised/optimised to allow the final arg - parser/validator to make decisions. - " - @opts - -badarg -type string -help\ - "name of an argument to highlight" - -parsedargs -type dict -help\ - "Result of successful punk::pargs::parse - (currently only looks at 'received')" - -aserror -type boolean -help\ - "If true, the usage table is raised as an error message, - otherwise it is returned as a value." - -return -choices {string table tableobject} -choicelabels { - string "no table layout" - tableobject "table object cmd" - table "full table layout" - } - -scheme -default error -choices {nocolour info error} - -form -default 0 -help\ - "Ordinal index or name of command form" - }] ] - - if {[catch {package require punk::ansi}]} { - proc punk::args::a {args} {} - proc punk::args::a+ {args} {} - } else { - namespace eval ::punk::args { - namespace import ::punk::ansi::a ::punk::ansi::a+ - } - } - variable arg_error_CLR - array set arg_error_CLR {} - set arg_error_CLR(errormsg) [a+ brightred] - set arg_error_CLR(title) "" - set arg_error_CLR(check) [a+ brightgreen] - set arg_error_CLR(solo) [a+ brightcyan] - set arg_error_CLR(choiceprefix) [a+ underline] - set arg_error_CLR(badarg) [a+ brightred] - set arg_error_CLR(goodarg) [a+ green strike] - set arg_error_CLR(goodchoice) [a+ reverse] - set arg_error_CLR(linebase_header) [a+ white] - set arg_error_CLR(cmdname) [a+ brightwhite] - set arg_error_CLR(groupname) [a+ bold] - set arg_error_CLR(ansiborder) [a+ bold] - set arg_error_CLR(ansibase_header) [a+ bold] - set arg_error_CLR(ansibase_body) [a+ white] - variable arg_error_CLR_nocolour - array set arg_error_CLR_nocolour {} - set arg_error_CLR_nocolour(errormsg) [a+ bold] - set arg_error_CLR_nocolour(title) [a+ bold] - set arg_error_CLR_nocolour(check) "" - set arg_error_CLR_nocolour(solo) "" - set arg_error_CLR_nocolour(badarg) [a+ reverse] ;#? experiment - set arg_error_CLR_nocolour(goodarg) [a+ strike] - set arg_error_CLR_nocolour(cmdname) [a+ bold] - set arg_error_CLR_nocolour(linebase_header) "" - set arg_error_CLR_nocolour(linebase) "" - set arg_error_CLR_nocolour(ansibase_body) "" - variable arg_error_CLR_info - array set arg_error_CLR_info {} - set arg_error_CLR_info(errormsg) [a+ brightred bold] - set arg_error_CLR_info(title) [a+ brightyellow bold] - set arg_error_CLR_info(check) [a+ brightgreen bold] - set arg_error_CLR_info(choiceprefix) [a+ brightgreen bold] - set arg_error_CLR_info(groupname) [a+ cyan bold] - set arg_error_CLR_info(ansiborder) [a+ brightcyan bold] - set arg_error_CLR_info(ansibase_header) [a+ cyan] - set arg_error_CLR_info(ansibase_body) [a+ white] - variable arg_error_CLR_error - array set arg_error_CLR_error {} - set arg_error_CLR_error(errormsg) [a+ brightred bold] - set arg_error_CLR_error(title) [a+ brightcyan bold] - set arg_error_CLR_error(check) [a+ brightgreen bold] - set arg_error_CLR_error(choiceprefix) [a+ brightgreen bold] - set arg_error_CLR_error(groupname) [a+ cyan bold] - set arg_error_CLR_error(ansiborder) [a+ brightyellow bold] - set arg_error_CLR_error(ansibase_header) [a+ yellow] - set arg_error_CLR_error(ansibase_body) [a+ white] - - - #bas ic recursion blocker - variable arg_error_isrunning 0 - proc arg_error {msg spec_dict args} { - #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. - #accept an option here so that we can still use full output for usage requests. - #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args - #Development/experimentation may be done with full table-based error reporting - but for production release it - #may be desirable to reduce overhead on catches. - #consider per-namespace or namespace-tree configurability. - #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due - #to resource availability etc - so the slower error generation time may not always be a problem. - #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling - #code which has no use for the enhanced error info. - #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. - #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system - #todo - #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error - #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) - - #todo - document unnamed leaders and unnamed values where -min and/or -max specified - #e.g punk::args::parse {} withdef {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} - #only |?-x?|string|... is shown in the output table. - #should be something like: - # |arg | - # |?-x? | - # |arg | - # |?arg...?| - # Where/how to specify counts? - #also.. - # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? - # - - - #limit colours to standard 16 so that themes can apply to help output - variable arg_error_isrunning - if {$arg_error_isrunning} { - error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" - } - - if {[llength $args] %2 != 0} { - error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" - } - - set arg_error_isrunning 1 - - set badarg "" - set parsedargs [dict create] ;#dict with keys: leaders,opts,values,received,solos,multis (as from punk::args::parse) - set goodargs [list] - set returntype table ;#table as string - set as_error 1 ;#usual case is to raise an error - set scheme error - set form 0 - dict for {k v} $args { - set fullk [tcl::prefix::match -error "" {-badarg -parsedargs -aserror -return -scheme -form} $k] - switch -- $fullk { - -badarg { - set badarg $v - } - -parsedargs { - #todo? - dict for {set setinfo} $v { - switch -- $set { - received { - foreach {r rpos} $setinfo { - if {$r ni $goodargs} { - lappend goodargs $r - } - } - } - } - } - set parsedargs $v - } - -aserror { - if {![string is boolean -strict $v]} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" - } - set as_error $v - } - -scheme { - set scheme $v - } - -return { - if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" - } - set returntype $v - } - -form { - set form $v - } - default { - set arg_error_isrunning 0 - error "arg_error invalid option $k. Known_options: -badarg -parsedargs -aserror -scheme -return -form" - } - } - } - #todo - scheme - use config and iterm toml definitions etc - switch -- $scheme { - "" - -nocolor - -nocolour { - set scheme nocolour - } - info - error {} - default { - set scheme na - } - } - set formnames [dict get $spec_dict form_names] - if {[string is integer -strict $form]} { - if {$form < 0 || $form > [llength $formnames]-1} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" - } - set selected_forms [list [lindex $formnames $form]] - } else { - if {$form eq "*"} { - set selected_forms $formnames - } else { - if {$form in $formnames} { - set selected_forms [list $form] - } else { - set arg_error_isrunning 0 - error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" - } - } - } - - - #hack some basics for now. - #for coloured schemes - use bold as well as brightcolour in case colour off. - upvar ::punk::args::arg_error_CLR CLR - - switch -- $scheme { - nocolour { - variable arg_error_CLR_nocolour - array set CLR [array get arg_error_CLR_nocolour - } - info { - variable arg_error_CLR_info - array set CLR [array get arg_error_CLR_info] - } - error { - variable arg_error_CLR_error - array set CLR [array get arg_error_CLR_error] - } - na { - } - } - - - #set RST [a] - set RST "\x1b\[m" - set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. - - #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error - #e.g list_as_table - - # use basic colours here to support terminals without extended colours - #todo - add checks column (e.g -minsize -maxsize) - set errmsg $msg - if {![catch {package require textblock}]} { - set has_textblock 1 - } else { - set has_textblock 0 - #couldn't load textblock package - #just return the original errmsg without formatting - } - set use_table 0 - if {$has_textblock && $returntype in {table tableobject}} { - set use_table 1 - } - set errlines [list] ;#for non-textblock output - if {[catch { - if {$use_table} { - append errmsg \n - } else { - if {($returntype in {table tableobject}) && !$has_textblock} { - append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n - } else { - append errmsg \n - } - } - set cmdname [Dict_getdef $spec_dict cmd_info -name ""] - set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] - - set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] - set docurl [Dict_getdef $spec_dict doc_info -url ""] - - #set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] - #set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] - #if {"$argdisplay_header$argdisplay_body" eq ""} { - # set is_custom_argdisplay 0 - #} else { - # set is_custom_argdisplay 1 - #} - - #temp - TODO - set argdisplay_header "" - set argdisplay_body "" - set is_custom_argdisplay 0 - - - set blank_header_col [list] - if {$cmdname ne ""} { - lappend blank_header_col "" - set cmdname_display $CLR(cmdname)$cmdname$RST - } else { - set cmdname_display "" - } - if {$cmdhelp ne ""} { - lappend blank_header_col "" - #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] - set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] - } else { - set cmdhelp_display "" - } - if {$docurl ne ""} { - lappend blank_header_col "" - set docurl_display [a+ white]$docurl$RST - } else { - set docurl_display "" - } - #synopsis - set synopsis "" - set form_info [dict get $spec_dict form_info] - dict for {fid finfo} $form_info { - set form_synopsis [Dict_getdef $finfo -synopsis ""] - if {$form_synopsis eq ""} { - #todo - set form_synopsis [punk::args::synopsis -form $fid [dict get $spec_dict id]] - if {[string length $form_synopsis] > 90} { - set form_synopsis [punk::args::synopsis -return summary -form $fid [dict get $spec_dict id]] - } - if {[string match (autodef)* $form_synopsis]} { - set form_synopsis [string range $form_synopsis 9 end] - } - } - if {$fid in $selected_forms} { - set form_synopsis [punk::ansi::a+ underline]$form_synopsis[punk::ansi::a+ nounderline] - } - append synopsis $form_synopsis \n - } - if {$synopsis ne ""} { - set synopsis [string trimright $synopsis \n] - lappend blank_header_col "" - } - - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - if {$use_table} { - set t [textblock::class::table new "$CLR(title)Usage$RST"] - $t add_column -headers $blank_header_col -minwidth 3 - $t add_column -headers $blank_header_col - - if {!$is_custom_argdisplay} { - lappend blank_header_col "" - #spanned columns in default argdisplay area - $t add_column -headers $blank_header_col ;#Default - $t add_column -headers $blank_header_col ;#Multi - $t add_column -headers $blank_header_col ;#Help - set arg_colspans {1 4 0 0 0} - } else { - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - set arg_colspans {1 1} - } - } - set h 0 - if {$cmdname ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] - } else { - lappend errlines "COMMAND: $cmdname_display" - } - incr h - } - if {$cmdhelp ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] - } else { - lappend errlines "Description: $cmdhelp_display" - } - incr h - } - if {$docurl ne ""} { - if {![catch {package require punk::ansi}]} { - set docurl [punk::ansi::hyperlink $docurl] - } - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] - } else { - lappend errlines "$docname $docurl_display" - } - incr h - } - if {$synopsis ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Synopsis: [punk::ansi::ansiwrap brightwhite $synopsis]] - } else { - #todo - lappend errlines "Synopsis:\n$synopsis" - } - incr h - } - - - if {$use_table} { - if {$is_custom_argdisplay} { - if {$argdisplay_header ne ""} { - $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] - } - } else { - $t configure_header $h -values {Arg Type Default Multi Help} - } - } else { - lappend errlines " --ARGUMENTS-- " - } - - if {$is_custom_argdisplay} { - if {$use_table} { - #using overall container table - #header already added - #TODO - review textblock::table features - #we can't currently span columns within the table body. - #This feature could allow hidden data columns (and sort on hidden col?) - #potentially require coordination with header colspans? - $t add_row [list "" $argdisplay_body] - } else { - if {$argdisplay_header ne ""} { - lappend errlines $argdisplay_header - } - lappend errlines {*}$argdisplay_body - } - } else { - - #set A_DEFAULT [a+ brightwhite Brightgreen] - set A_DEFAULT "" - set A_BADARG $CLR(badarg) - set A_GOODARG $CLR(goodarg) - set A_GOODCHOICE $CLR(goodchoice) - set greencheck $CLR(check)\u2713$RST ;#green tick - set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply - if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { - #A_PREFIX can resolve to empty string if colour off - #we then want to display underline instead - set A_PREFIX [a+ underline] - set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space - } else { - set A_PREFIXEND $RST - } - - #TODO - foreach fid - set fid [lindex $selected_forms 0] - set form_dict [dict get $spec_dict FORMS $fid] - - set opt_names [list] - set opt_names_display [list] - if {[llength [dict get $form_dict OPT_NAMES]]} { - if {![catch {package require punk::trie}]} { - set trie [punk::trie::trieclass new {*}[dict get $form_dict OPT_NAMES]] - set idents [dict get [$trie shortest_idents ""] scanned] - #todo - check opt_prefixdeny - - $trie destroy - foreach c [dict get $form_dict OPT_NAMES] { - set arginfo [dict get $form_dict ARG_INFO $c] - if {[dict get $arginfo -prefix]} { - set id [dict get $idents $c] - #REVIEW - if {$id eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $id] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail - } else { - lappend opt_names_display $c - } - #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] - lappend opt_names $c - } - } else { - set opt_names [dict get $form_dict OPT_NAMES] - set opt_names_display $opt_names - } - } - set leading_val_names [dict get $form_dict LEADER_NAMES] - set trailing_val_names [dict get $form_dict VAL_NAMES] - - #dict for {argname info} [tcl::dict::get $form_dict arg_info] { - # if {![string match -* $argname]} { - # lappend leading_val_names [lpop trailing_val_names 0] - # } else { - # break - # } - #} - #if {![llength $leading_val_names] && ![llength $opt_names]} { - # #all vals were actually trailing - no opts - # set trailing_val_names $leading_val_names - # set leading_val_names {} - #} - set leading_val_names_display $leading_val_names - set trailing_val_names_display $trailing_val_names - #puts "--> parsedargs: $parsedargs" - set parsed_leaders [Dict_getdef $parsedargs leaders {}] - set parsed_opts [Dict_getdef $parsedargs opts {}] - set parsed_values [Dict_getdef $parsedargs values {}] - - #display options first then values - foreach argumentset [list [list $leading_val_names_display $leading_val_names $parsed_leaders] [list $opt_names_display $opt_names $parsed_opts] [list $trailing_val_names_display $trailing_val_names $parsed_values]] { - lassign $argumentset argnames_display argnames parsedvalues - - foreach argshow $argnames_display arg $argnames { - set arginfo [dict get $form_dict ARG_INFO $arg] - if {[dict exists $arginfo -default]} { - set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" - } else { - set default "" - } - set help [Dict_getdef $arginfo -help ""] - set allchoices_originalcase [list] - set choices [Dict_getdef $arginfo -choices {}] - set choicegroups [Dict_getdef $arginfo -choicegroups {}] - set choicemultiple [dict get $arginfo -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] - set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] - if {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - set is_multiple 1 - } else { - set multiple "" - set is_multiple 0 - } - if {[dict exists $choicegroups ""]} { - dict lappend choicegroups "" {*}$choices - } else { - set choicegroups [dict merge [dict create "" $choices] $choicegroups] - } - dict for {groupname clist} $choicegroups { - lappend allchoices_originalcase {*}$clist - } - set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] - - if {$has_choices} { - if {$help ne ""} {append help \n} - if {[dict get $arginfo -nocase]} { - set casemsg " (case insensitive)" - set allchoices_test [string tolower $allchoices_originalcase] - } else { - set casemsg " (case sensitive)" - set allchoices_test $allchoices_originalcase - } - if {[dict get $arginfo -choiceprefix]} { - set prefixmsg " (choice prefix allowed)" - } else { - set prefixmsg "" - } - set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] - set choiceinfodict [Dict_getdef $arginfo -choiceinfo {}] - set formattedchoices [dict create] ;#use dict rather than array to preserve order - append help " Choices$prefixmsg$casemsg" - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - if {$choicemultiple_max == -1} { - append help \n " The value can be a list of $choicemultiple_min or more of these choices" - } else { - if {$choicemultiple_min eq $choicemultiple_max} { - append help \n " The value must be a list of $choicemultiple_min of these choices" - } else { - append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" - } - } - } - if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c [join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } else { - #set formattedchoices $choicegroups - #set formattedchoices [dict get $arginfo -choices] - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c [join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } - } else { - if {[catch { - set trie [punk::trie::trieclass new {*}$allchoices_test] - set idents [dict get [$trie shortest_idents ""] scanned] - if {[dict get $arginfo -nocase]} { - #idents were calculated on lcase - remap keys in idents to original casing - set actual_idents $idents - foreach ch $allchoices_originalcase { - if {![dict exists $idents $ch]} { - #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting - #The actual testing is done in get_dict - dict set actual_idents $ch [dict get $idents [string tolower $ch]] - } - } - set idents $actual_idents - #puts "-----" - #puts "idents $idents" - } - - $trie destroy - dict for {groupname clist} $choicegroups { - foreach c $clist { - if {$c in $choiceprefixdenylist} { - set shortestid $c - } else { - set shortestid [dict get $idents $c] - } - if {$shortestid eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $shortestid] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set mk " [join $markers {}]" - } else { - set mk "" - } - set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]$mk" - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - #puts "-- parsed:$parsedvalues arg:$arg c:$c" - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } errM]} { - #this failure can happen if -nocase is true and there are ambiguous entries - #e.g -nocase 1 -choices {x X} - puts stderr "prefix marking failed\n$errM" - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c [join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } else { - #set formattedchoices $choicegroups - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c[join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } - - } - } - set choicetable_objects [list] - set choicetable_footers [dict create] - dict for {groupname formatted} $formattedchoices { - set numcols $choicecolumns ;#todo - dynamic? - if {[llength $formatted] < $numcols} { - #don't show blank cells if single line of results - set numcols [llength $formatted] - } - if {$numcols > 0} { - if {$use_table} { - #risk of recursing - #TODO -title directly in list_as_table - set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] - lappend choicetable_objects $choicetableobj - $choicetableobj configure -title $CLR(groupname)$groupname - #append help \n[textblock::join -- " " [$choicetableobj print]] - } else { - if {$groupname ne ""} { - append help \n \n "$CLR(groupname)Group: $groupname$RST" - } else { - append help \n - } - append help \n [join $formatted \n] - } - } else { - #we were given an empty set of choices. - #probably an error in the definition - but could happen if dynamically generated. - #(e.g ensemble where unknown mechanism is used for subcommands?) - #better to just display that there were none rather than totally break the usage output. - if {$usetable} { - #these will be displayed after all table entries - if {$groupname eq ""} { - dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" - } else { - dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" - } - } else { - if {$groupname eq ""} { - append help \n " " $CLR(errormsg)(no choices defined)$RST - } else { - append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST - } - } - } - } - set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width - foreach obj $choicetable_objects { - dict lappend twidths_by_colcount [$obj column_count] [$obj width] - } - foreach obj $choicetable_objects { - set cols [$obj column_count] - set widths [dict get $twidths_by_colcount $cols] - set max [tcl::mathfunc::max {*}$widths] - $obj configure -minwidth $max ;#expand smaller ones - set i 0 - while {$i < $cols} { - #keep text aligned left on expanded tables - $obj configure_column $i -blockalign left - incr i - } - - append help \n[textblock::join -- " " [$obj print]] - #set ansititle [dict get [$obj configure -title] value] - $obj destroy - } - if {[dict size $choicetable_footers]} { - foreach groupname [dict keys $formattedchoices] { - if {[dict exists $choicetable_footers $groupname]} { - append help \n [dict get $choicetable_footers $groupname] - } - } - } - - #review. use -type to restrict additional choices - may be different to values in the -choices - if {![dict get $arginfo -choicerestricted]} { - #when -choicemultiple - the -type refers to each selection - if {[dict get $arginfo -type] eq "string"} { - append help "\n (values not in defined choices are allowed)" - } else { - append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" - } - } - } - if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { - if {$is_multiple} { - set argshow "?${argshow}...?" - } else { - set argshow "?${argshow}?" - } - } else { - if {$is_multiple} { - set argshow "${argshow}..." - } - } - set typeshow [dict get $arginfo -type] - if {$typeshow eq "none"} { - set typeshow "$typeshow $soloflag" - } - if {[dict exists $arginfo -minsize]} { - append typeshow \n "-minsize [dict get $arginfo -minsize]" - } - if {[dict exists $arginfo -maxsize]} { - append typeshow \n "-maxsize [dict get $arginfo -maxsize]" - } - if {[dict exists $arginfo -range]} { - append typeshow \n "-range [dict get $arginfo -range]" - } - - if {$use_table} { - $t add_row [list $argshow $typeshow $default $multiple $help] - if {$arg eq $badarg} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG - } elseif {$arg in $goodargs} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $A_GOODARG - } - } else { - #review - formatting will be all over the shop due to newlines in typesshow, help - set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" - if {$arg eq $badarg} { - set arghelp [punk::ansi::ansiwrap -rawansi $A_BADARG $arghelp] - } elseif {$arg in $goodargs} { - set arghelp [punk::ansi::ansiwrap -rawansi $A_GOODARG $arghelp] - } - foreach ln [split $help \n] { - append arghelp " $ln" \n - } - lappend errlines $arghelp - } - } - } - } ;#end is_custom_argdisplay - - if {$use_table} { - $t configure -show_hseps 0\ - -show_header 1\ - -ansibase_body $CLR(ansibase_body)\ - -ansibase_header $CLR(ansibase_header)\ - -ansiborder_header $CLR(ansiborder)\ - -ansiborder_body $CLR(ansiborder) - - $t configure -maxwidth 80 ;#review - if {$returntype ne "tableobject"} { - append errmsg [$t print] - #returntype of table means just the text of the table - $t destroy - } - } else { - append errmsg [join $errlines \n] - } - } errM]} { - catch {$t destroy} - append errmsg \n - append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n - append errmsg "$errM" \n - append errmsg "$::errorInfo" - - } - set arg_error_isrunning 0 - if {$use_table} { - #assert returntype is one of table, tableobject - set result $errmsg ;#default if for some reason table couldn't be used - if {$returntype eq "tableobject"} { - if {[info object isa object $t]} { - set result $t - } - } - } else { - set result $errmsg - } - if {$as_error} { - #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. - #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) - uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] - } else { - return $result - } - } - - - lappend PUNKARGS [list { - @dynamic - @id -id ::punk::args::usage - @cmd -name punk::args::usage -help\ - "Return usage information for a command identified by an id. - - This will only work for commands where a punk::args definition exists - for the command and an id has been defined for it. The id for custom - help for a command should match the fully qualified name of the command. - - Many commands (such as ensembles and oo objects) may have argument - documentation generated dynamically and may not yet have an id. - IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. - - Generally punk::ns::arginfo (aliased as i in the punk shell) should - be used in preference - as it will search for a documentation - mechanism and call punk::args::usage as necessary. - " - -return -default table -choices {string table tableobject} - }\ - {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}}\ - {${[punk::args::resolved_def -types opts ::punk::args::resolved_def -form]}}\ - { - - @values -min 0 -max 1 - id -help\ - "Exact id. - Will usually match the command name" - }] - proc usage {args} { - #lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received - lassign [dict values [punk::args::parse $args withid ::punk::args::usage]] leaders opts values received - set id [dict get $values id] - set real_id [real_id $id] - if {$real_id eq ""} { - error "punk::args::usage - no such id: $id" - } - #-scheme punk_info ?? - arg_error "" [punk::args::get_spec $real_id] {*}$opts -aserror 0 - } - - lappend PUNKARGS [list { - @id -id ::punk::args::get_by_id - @cmd -name punk::args::get_by_id - @values -min 1 - id - arglist -type list -help\ - "list containing arguments to be parsed as per the - argument specification identified by the supplied id." - }] - - - #deprecate? - proc get_by_id {id arglist} { - set definitionlist [punk::args::raw_def $id] - if {[llength $definitionlist] == 0} { - error "punk::args::get_by_id - no such id: $id" - } - #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] - tailcall ::punk::args::get_dict $definitionlist $arglist - } - - #consider - - #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) - #parse ?-flag val?... -- $arglist withid $id - #parse ?-flag val?... -- $arglist withdef $def ?$def?... - - #an experiment.. ideally we'd like arglist at the end? - #parse_withid ?-flag val?.. $id $arglist - #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? - #no possible equivalent for parse_withdef ??? - - lappend PUNKARGS [list { - @id -id ::punk::args::parse - @cmd -name punk::args::parse -help\ - "parse and validate command arguments based on a definition. - - In the 'withid' form the definition is a pre-existing record that has been - created with ::punk::args::define, or indirectly by adding a definition to - the PUNKARGS variable in a namespace which is then registered in - punk::args::register::NAMESPACES, or by a previous call to punk::parse - using 'withdef' and a definition block containing an @id -id directive. - - In the 'withdef' form - the definition is created on the first call and - cached thereafter, if the id didn't already exist. - - form1: parse $arglist ?-flag val?... withid $id - form2: parse $arglist ?-flag val?... withdef $def ?$def? - see punk::args::define - - Returns a dict of information regarding the parsed arguments - example of basic usage for single option only: - punk::args::define { - @id -id ::myns::myfunc - @cmd -name myns::myfunc - @leaders -min 0 -max 0 - @opts - -configfile -type existingfile - #type none makes it a solo flag - -verbose -type none - @values -min 0 -max 0 - } - proc myfunc {args} { - set argd [punk::args::parse $args withid ::myns::myfunc] - lassign [dict values $argd] leaders opts values received solos - if {[dict exists $received] -configfile} { - puts \"have option for existing file [dict get $opts -configfile]\" - } - } - The leaders, opts, values keys in the parse result dict are proper dicts. - The received key is dict-like but can have repeated keys for arguments than can - accept multiples. The value for each received element is the ordinal position. - The solos key refers to a list of solo flags received (those specified with - -type none). This is generally only useful to assist in passing arguments on - to another procedure which also requires solos, because the opts dict contains - solo flags with a 1 value or a list of 1's if it was a solo with -multiple true - specified. - " - @form -form {withid withdef} - @leaders -min 1 -max 1 - arglist -type list -optional 0 -help\ - "Arguments to parse - supplied as a single list" - - @opts - -form -type list -default * -help\ - "Restrict parsing to the set of forms listed. - Forms are the orthogonal sets of arguments a - command can take - usually described in 'synopsis' - entries." - #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance - #todo - configurable per interp/namespace - -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} - - @values -min 2 - - @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" - @values -max 2 - withid -type literal -help\ - "The literal value 'withid'" - id -type string -help\ - "id of punk::args definition for a command" - - - @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" - withdef -type literal -help\ - "The literal value 'withdef'" - - #todo - make -dynamic obsolete - use @dynamic directive instead - def -type string -multiple 1 -optional 0 -help\ - "Each remaining argument is a block of text - defining argument definitions. - As a special case, -dynamic may be - specified as the 1st 2 arguments. These are - treated as an indicator to punk::args about - how to process the definition." - - }] - proc parse {args} { - set tailtype "" ;#withid|withdef - if {[llength $args] < 3} { - #error "punk::args::parse - invalid call. < 3 args" - punk::args::parse $args withid ::punk::args::parse - } - set opts_and_vals $args - set parseargs [lpop opts_and_vals 0] - - set opts [list] - set values [list] - for {set i 0} {$i < [llength $opts_and_vals]} {incr i} { - if {[string match -* [lindex $opts_and_vals $i]]} { - if {[catch { - lappend opts [lpop opts_and_vals 0] [lpop opts_and_vals 0] - }]} { - #unhappy path - not enough options - #review - which form of punk::args::parse? - punk::args::parse $args withid ::punk::args::parse - } - incr i -1 - #lappend opts $a [lindex $opts_and_vals $i] - } else { - break - } - } - #set values [lrange $opts_and_vals $i end] - set values $opts_and_vals - #puts "---values: $values" - set tailtype [lindex $values 0] - set tailargs [lrange $values 1 end] - - - #set split [lsearch -exact $tailargs withid] - #if {$split < 0} { - # set split [lsearch -exact $tailargs withdef] - # if {$split < 0} { - # #punk::args::usage arg_error? - # #error "punk::args::parse - invalid call. keyword withid|withdef required" - # punk::args::parse $args withid ::punk::args::parse - # } else { - # set tailtype withdef - #} - #} else { - # set tailtype withid - #} - #set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. - - - #if {[llength $opts] % 2} { - #error "punk::args::parse Even number of -flag val pairs required after arglist" - #} - - #Default the -errorstyle to enhanced - # (slowest on unhappy path - but probably clearest for playing with new APIs interactively) - # - application devs should distribute a config file with an errorstyle override if desired. - # - devs who prefer a different default for interactive use should create a config for it. (todo) - set defaultopts [dict create\ - -form {*}\ - -errorstyle enhanced\ - ] - - #todo - load override_errorstyle from configuration - #dict set defaultopts -errorstyle $ - #puts "def: $defaultopts opts: $opts" - set opts [dict merge $defaultopts $opts] - dict for {k v} $opts { - switch -- $k { - -form - -errorstyle { - } - default { - #punk::args::usage $args withid ::punk::args::parse ?? - #error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" - punk::args::parse $args withid ::punk::args::parse - } - } - } - switch -- $tailtype { - withid { - if {[llength $tailargs] != 1} { - #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - punk::args::parse $args withid ::punk::args::parse - } - set id [lindex $tailargs 0] - #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" - set deflist [raw_def $id] - if {[llength $deflist] == 0} { - error "punk::args::parse - no such id: $id" - } - } - withdef { - set deflist $tailargs - if {[llength $deflist] < 1} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" - } - default { - error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" - } - } - try { - set result [punk::args::get_dict $deflist $parseargs -form [dict get $opts -form]] - } trap {PUNKARGS VALIDATION} {msg erroropts} { - set opt_errorstyle [dict get $opts -errorstyle] - - #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - - - set ecode [dict get $erroropts -errorcode] - #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... - set msg [string map [list %caller% [Get_caller]] $msg] - switch -- $opt_errorstyle { - minimal { - return -options [list -code error -errorcode $ecode] $msg - } - basic { - #No table layout - unix manpage style - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg -form [dict get $opts -form]] - } - return -options [list -code error -errorcode $ecode] $msg - } - standard { - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] - } - return -options [list -code error -errorcode $ecode] $msg - } - enhanced { - set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below) - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - set ecode_summary [lrange $ecode 0 2] - if {$badarg ne ""} { - lappend ecode_summary -badarg $badarg - } - catch {package require punk::lib} - if {[package provide punk::lib] ne ""} { - append msg \n [punk::lib::showdict -roottype list $estack */*] - } - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] - append msg \n "::errorCode summary: $ecode_summary" - return -options [list -code error -errorcode $ecode] $msg - } else { - #why? todo? - append msg \n "(enhanced error information unavailable)" - append msg \n "::errorCode summary: $ecode_summary" - return -options [list -code error -errorcode $ecode] $msg - } - } - debug { - puts stderr "errorstyle debug not implemented" - return -options [list -code error -errorcode $ecode] $msg - } - default { - puts stderr "errorstyle $opt_errorstyle not recognised: expected one of minimal basic standard enhanced debug" - return -options [list -code error -errorcode $ecode] $msg - } - } - } trap {PUNKARGS} {msg erropts} { - append msg \n "Unexpected PUNKARGS error" - return -options [list -code error -errorcode $ecode] $msg - } trap {} {msg erroropts} { - #review - #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. - #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. - throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] - } - return $result - } - proc parseXXX {args} { - #no solo flags allowed for parse function itself. (ok for arglist being parsed) - set opts [dict create] ;#repeated flags will override earlier. That's ok here. - set arglist {} - set got_arglist 0 - set tailtype "" ;#withid|withdef - set id "" - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {[string match -* $a]} { - dict set opts $a [lindex $args $i+1] - incr i - } else { - set arglist $a - set got_arglist 1 - set tailtype [lindex $args $i+1] - if {$tailtype eq "withid"} { - if {[llength $args] != $i+3} { - error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - } - set id [lindex $args $i+2] - break - } elseif {$tailtype eq "withdef"} { - if {[llength $args] < $i+3} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - set deflist [lrange $args $i+2 end] - break - } else { - error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" - } - } - } - if {!$got_arglist} { - error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." - } - #assert tailtype eq withid|withdef - if {$tailtype eq "withid"} { - #assert $id was provided - return "parse [llength $arglist] args withid $id, options:$opts" - } else { - #assert llength deflist >=1 - return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" - } - #TODO - } - - #todo? - a version of get_dict that directly supports punk::lib::tstr templating - #rename get_dict - # - - #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 get_dict {deflist rawargs args} { - #see arg_error regarding considerations around unhappy-path performance - - if {[llength $args] % 2 != 0} { - error "punk::args::get_dict args must be a dict of option value pairs" - } - set defaults [dict create\ - -form *\ - ] - set opts [dict merge $defaults $args] - dict for {k v} $opts { - switch -- $k { - -form {} - default { - error "punk::args::get_dict Unexpected option '$k' Known options -form" - } - } - } - - - #*** !doctools - #[call [fun get_dict] [arg deflist] [arg rawargs] [arg args]] - #[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 values - #[para]ARGUMENTS: - #[list_begin arguments] - #[arg_def list-of-multiline-string deflist] - #[para] These are blocks 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 defining a flag 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 - #[para]Each optionspec line defining a positional argument is of the form: - #[para]argumentname -key val -ky2 val2... - #[para]where the valid keys for each option specification are: -default -type -range -choices - #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value - #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. - #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. - #[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, - #but it could be a manually constructed list of values made for example from positional args defined in the proc. - #[list_end] - #[para] - - #consider line-processing example below for which we need info complete to determine record boundaries - #punk::args::get_dict [list { - # @opts - # -opt1 -default {} - # -opt2 -default { - # etc - # } - # @values -multiple 1 - #}] $args - - - - - #rawargs: args values to be parsed - #we take a definition list rather than resolved argspecs - because the definition could be dynamic - - #if definition has been seen before, - #define will either return a permanently cached argspecs (-dynamic 0) - or - # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. - set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]] - - # ----------------------------------------------- - # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) - tcl::dict::with argspecs {} ;#turn keys into vars - #e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info,id_info,form_names - # ----------------------------------------------- - set opt_form [dict get $opts -form] - if {$opt_form eq "*"} { - set selected_forms $form_names - } elseif {[string is integer -strict $opt_form]} { - if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { - error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set selected_forms [list [lindex $form_names $opt_form]] - } else { - if {$opt_form ni $form_names} { - error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set selected_forms [list $opt_form] - } - - - #puts "-arg_info->$arg_info" - set flagsreceived [list] ;#for checking if required flags satisfied - set solosreceived [list] - set multisreceived [list] - #secondary purpose: - #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 ? - - # -- --- --- --- - # Handle leading positionals - # todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ? - - #todo - handle multiple fids? - set fid [lindex $selected_forms 0] - set formdict [dict get $FORMS $fid] - tcl::dict::with formdict {} - #populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc - if {$VAL_MIN eq ""} { - set valmin 0 - set VAL_MIN 0 - } else { - set valmin $VAL_MIN - } - - set pre_values {} - - set argnames [tcl::dict::keys $ARG_INFO] - set optnames [lsearch -all -inline $argnames -*] - set ridx 0 - set rawargs_copy $rawargs - set leader_posn_name "" - set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) - set is_multiple 0 ;#last leader may be multi - if {$LEADER_MAX != 0} { - foreach r $rawargs_copy { - if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { - break - } - if {$ridx == [llength $LEADER_NAMES]-1} { - #at last named leader - set leader_posn_name [lindex $LEADER_NAMES $ridx] - if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { - set is_multiple 1 - } - } elseif {$ridx > [llength $LEADER_NAMES]-1} { - #beyond names - retain name if -multiple was true - if {!$is_multiple} { - set leader_posn_name "" - } - } else { - set leader_posn_name [lindex $LEADER_NAMES $ridx] ;#may return empty string - } - if {$r eq "--"} { - #review end of opts marker: '--' can't be a leader (but can be a value) - break - } - - #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option - if {[tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { - set matchopt [::tcl::prefix::match -error {} $optnames $r] - if {$matchopt ne ""} { - #flaglike matches a known flag - don't treat as leader - break - } - #if {![string match -* [lindex $argnames $ridx]]} {} - if {$leader_posn_name ne ""} { - #there is a named leading positional for this position - #The flaglooking value doesn't match an option - so treat as a leader - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - incr ridx - continue - } else { - break - } - } - - #for each branch - break or lappend - if {$leader_posn_name ne ""} { - if {$leader_posn_name ni $LEADER_REQUIRED} { - #optional leader - - #most adhoc arg processing will allocate based on number of args rather than matching choice values first - #(because a choice value could be a legitimate data value) - - #review - option to process in this manner? - #first check if the optional leader value is a match for a choice ? - #if {[dict exists $arg_info $leader_posn_name -choices]} { - # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] [lindex $rawargs 0]] - # if {$vmatch ne ""} { - # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values - # lappend pre_values [lpop rawargs 0] - # incr ridx - # continue - # } - #} - - #check if enough rawargs to fill any required values - if {$VAL_MIN > 0 && [llength $rawargs] <= $VAL_MIN || [llength $rawargs] <= [llength $VAL_REQUIRED]} { - break - } else { - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #required - if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { - #already accepted at least one value - requirement satisfied - now equivalent to optional - if {$VAL_MIN > 0 && [llength $rawargs] <= $VAL_MIN || [llength $rawargs] <= [llength $VAL_REQUIRED]} { - break - } - } - #if we didn't break - requirement is not yet satisfied, or is satisfied but stil enough rawargs for required values - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #unnamed leader - if {$LEADER_MIN ne "" } { - if {$ridx > $LEADER_MIN-1} { - if {$LEADER_MAX ne "" && $ridx == $LEADER_MAX} { - break - } else { - if {$VAL_MIN ne ""} { - if {[llength $rawargs] > $VAL_MIN} { - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } else { - break - } - } else { - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } - } else { - #haven't reached LEADER_MIN - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - break - } - } - - incr ridx - } ;# end foreach r $rawargs_copy - } - - set argstate $ARG_INFO ;#argstate may have entries added - set arg_checks $ARG_CHECKS - - #JJJJ - if {$LEADER_MIN eq ""} { - set leadermin 0 - } else { - set leadermin $LEADER_MIN - } - if {$LEADER_MAX eq ""} { - set leadermax -1 - } else { - set leadermax $LEADER_MAX - } - - if {$VAL_MAX eq ""} { - set valmax -1 - } else { - set valmax $VAL_MAX - } - - #assert leadermax leadermin are numeric - #assert - rawargs has been reduced by leading positionals - - set opts [dict create] ;#don't set to OPT_DEFAULTS here - - - set leaders [list] - set arglist {} - set post_values {} - #valmin, valmax - #puts stderr "rawargs: $rawargs" - #puts stderr "argstate: $argstate" - if {[lsearch $rawargs -*] >= 0} { - #at least contains flaglike things.. - set maxidx [expr {[llength $rawargs] -1}] - if {$valmax == -1} { - set vals_total_possible [llength $rawargs] - set vals_remaining_possible $vals_total_possible - } else { - set vals_total_possible $valmax - set vals_remaining_possible $vals_total_possible - } - for {set i 0} {$i <= $maxidx} {incr i} { - set a [lindex $rawargs $i] - set remaining_args_including_this [expr {[llength $rawargs] - $i}] - #lowest valmin is 0 - if {$remaining_args_including_this <= $valmin} { - # if current arg is -- it will pass through as a value here - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - - #exlude argument with whitespace from being a possible option e.g dict - if {[tcl::string::match -* $a] && !([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { - if {$a eq "--"} { - #remaining num args <= valmin already covered above - if {$valmax != -1} { - #finite max number of vals - if {$remaining_args_including_this == $valmax} { - #assume it's a value. - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - } else { - #assume it's an end-of-options marker - lappend flagsreceived -- - set arglist [lrange $rawargs 0 $i] - set post_values [lrange $rawargs $i+1 end] - } - } else { - #unlimited number of post_values accepted - #treat this as eopts - we don't care if remainder look like options or not - lappend flagsreceived -- - set arglist [lrange $rawargs 0 $i] - set post_values [lrange $rawargs $i+1 end] - } - break - } else { - set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] - if {$fullopt ne ""} { - if {![tcl::dict::get $argstate $fullopt -prefix] && $a ne $fullopt} { - #attempt to use a prefix when not allowed - #review - by ending opts here - we dont' get the clearest error msgs - # may *sometimes* be better to raise a PUNKARGS VALIDATION (invalidoption) error - # (but it may actually be the first value that just happens to be flaglike) - #todo - check for subsequent valid flags or -- marker? - #consider for example 'file delete -f -- old.txt' - #If we just end option-processing, the punk::args parser would pass {-f -- old.txt} as values - #whereas the builtin file arg parser alerts that -f is a bad option - set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg - #set arglist [lrange $rawargs 0 $i-1] - #set post_values [lrange $rawargs $i end] - #break - } - if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { - #non-solo - #check if it was actually a value that looked like a flag - if {$i == $maxidx} { - #if no optvalue following - assume it's a value - #(caller should probably have used -- before it) - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - - set flagval [lindex $rawargs $i+1] - if {[tcl::dict::get $argstate $fullopt -multiple]} { - #don't lappend to default - we need to replace if there is a default - if {$fullopt ni $flagsreceived} { - tcl::dict::set opts $fullopt [list $flagval] - } else { - tcl::dict::lappend opts $fullopt $flagval - } - if {$fullopt ni $multisreceived} { - lappend multisreceived $fullopt - } - } else { - tcl::dict::set opts $fullopt $flagval - } - #incr i to skip flagval - incr vals_remaining_possible -2 - if {[incr i] > $maxidx} { - set msg "Bad options for %caller%. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $fullopt index [expr {$i-1}]] -badarg $fullopt -argspecs $argspecs]] $msg - } - } else { - #solo - if {[tcl::dict::get $argstate $fullopt -multiple]} { - if {$fullopt ni $flagsreceived} { - #override any default - don't lappend to it - tcl::dict::set opts $fullopt 1 - } else { - tcl::dict::lappend opts $fullopt 1 - } - if {$fullopt ni $multisreceived} { - lappend multisreceived $fullopt - } - } else { - tcl::dict::set opts $fullopt 1 - } - incr vals_remaining_possible -1 - lappend solosreceived $fullopt ;#dups ok - } - lappend flagsreceived $fullopt ;#dups ok - } else { - #unmatched option flag - #comparison to valmin already done above - if {$valmax ne -1 && $remaining_args_including_this <= $valmax} { - #todo - look at optspec_default and see if solo/vs opt-val pair - #we may need to lookahead by 2 regarding valmax valmin - - #even with optany - assume an unknown within the space of possible values is a value - #unmatched option in right position to be considered a value - treat like eopts - #review - document that an unspecified arg within range of possible values will act like eopts -- - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - if {$OPT_ANY} { - set newval [lindex $rawargs $i+1] - #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option - tcl::dict::set argstate $a $OPTSPEC_DEFAULTS ;#use default settings for unspecified opt - tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS - if {[tcl::dict::get $argstate $a -type] ne "none"} { - if {[tcl::dict::get $argstate $a -multiple]} { - tcl::dict::lappend opts $a $newval - if {$a ni $multisreceived} { - lappend multisreceived $a - } - } else { - tcl::dict::set opts $a $newval - } - if {[incr i] > $maxidx} { - set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg - #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a - } - incr vals_remaining_possible -2 - } else { - #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none - if {[tcl::dict::get $argstate $a -multiple]} { - if {![tcl::dict::exists $opts $a]} { - tcl::dict::set opts $a 1 - } else { - tcl::dict::lappend opts $a 1 - } - if {$a ni $multisreceived} { - lappend multisreceived $a - } - } else { - tcl::dict::set opts $a 1 - } - incr vals_remaining_possible -1 - lappend solosreceived $a - } - lappend flagsreceived $a ;#adhoc flag as supplied - } else { - if {[llength $OPT_NAMES]} { - set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" - } else { - set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" - } - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg - #arg_error $errmsg $argspecs -badarg $fullopt - } - } - } - } else { - #not flaglike - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - } - #set values [list {*}$pre_values {*}$post_values] - set leaders $pre_values - set values $post_values - } else { - set leaders $pre_values - set values $rawargs - #set values [list {*}$pre_values {*}$rawargs] ;#no -flags detected - set arglist [list] - } - #puts stderr "--> arglist: $arglist" - #puts stderr "--> values: $values" - - #--------------------------------------- - set ordered_opts [dict create] - foreach o $OPT_NAMES { - if {[dict exists $opts $o]} { - dict set ordered_opts $o [dict get $opts $o] - } elseif {[dict exists $OPT_DEFAULTS $o]} { - dict set ordered_opts $o [dict get $OPT_DEFAULTS $o] - } - } - #add in possible '-any true' opts after the defined opts - dict for {o oval} $opts { - if {![dict exists $ordered_opts $o]} { - dict set ordered_opts $o $oval - } - } - set opts $ordered_opts - #--------------------------------------- - - - set positionalidx 0 ;#index for unnamed positionals (both leaders and values) - set ldridx 0 - set in_multiple "" - set leadernames_received [list] - - set num_leaders [llength $leaders] - #---------------------------------------- - #set leaders_dict $LEADER_DEFAULTS ;#wrong - set leaders_dict [dict create] - foreach lname [lrange $LEADER_NAMES 0 $num_leaders-1] { - dict set leaders_dict $lname {} - } - set leaders_dict [dict merge $leaders_dict $LEADER_DEFAULTS] - #---------------------------------------- - - foreach leadername $LEADER_NAMES ldr $leaders { - if {$ldridx+1 > $num_leaders} { - break - } - if {$leadername ne ""} { - if {[tcl::dict::get $argstate $leadername -multiple]} { - if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { - tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list - } else { - tcl::dict::lappend leaders_dict $leadername $ldr - } - set in_multiple $leadername - } else { - tcl::dict::set leaders_dict $leadername $ldr - } - lappend leadernames_received $leadername - } else { - if {$in_multiple ne ""} { - tcl::dict::lappend leaders_dict $in_multiple $ldr - lappend leadernames_received $in_multiple ;#deliberately allow dups! (as with opts and values) - } else { - tcl::dict::set leaders_dict $positionalidx $ldr - tcl::dict::set argstate $positionalidx $LEADERSPEC_DEFAULTS - tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS - lappend leadernames_received $positionalidx - } - } - incr ldridx - incr positionalidx - } - - - set validx 0 - set valname_multiple "" - set valnames_received [list] - - set num_values [llength $values] - #------------------------------------------ - #!!! review - ## Don't set values_dict to VAL_DEFAULTS - or order of values_dict will be intermittently wrong based on whether values have defaults - ## set values_dict $val_defaults - set values_dict [dict create] - foreach valname [lrange $VAL_NAMES 0 $num_values-1] { - dict set values_dict $valname {} - } - set values_dict [dict merge $values_dict $VAL_DEFAULTS] - #------------------------------------------ - set nameidx 0 - set start_position $positionalidx - for {set validx 0} {$validx < [llength $values]} {incr validx} { - set valname [lindex $VAL_NAMES $nameidx] - incr nameidx - set val [lindex $values $validx] - if {$valname ne ""} { - if {[llength $valname] == 1} { - set strideval $val - } else { - set strideval [list] - incr validx -1 - foreach v $valname { - incr validx - if {$validx > [llength $values]-1} { - set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname', but requires [llength $valname] values." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname] ] -argspecs $argspecs]] $msg - } - lappend strideval [lindex $values $validx] - } - } - - if {[tcl::dict::get $argstate $valname -multiple]} { - if {[tcl::dict::exists $VAL_DEFAULTS $valname]} { - #current stored val equals defined default - don't include default in the list we build up - tcl::dict::set values_dict $valname [list $strideval] ;#important to treat first element as a list - } else { - tcl::dict::lappend values_dict $valname $strideval - } - set valname_multiple $valname - } else { - tcl::dict::set values_dict $valname $strideval - } - lappend valnames_received $valname - } else { - if {$valname_multiple ne ""} { - if {[llength $valname_multiple] == 1} { - set strideval $val - } else { - set strideval [list] - incr validx -1 - foreach v $valname_multiple { - incr validx - if {$validx > [llength $values]-1} { - set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname_multiple', but requires [llength $valname_multiple] values." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname_multiple] ] -argspecs $argspecs]] $msg - } - lappend strideval [lindex $values $validx] - } - } - tcl::dict::lappend values_dict $valname_multiple $strideval - #name already seen - but must add to valnames_received anyway (as with opts and leaders) - lappend valnames_received $valname_multiple - } else { - tcl::dict::set values_dict $positionalidx $val - tcl::dict::set argstate $positionalidx $VALSPEC_DEFAULTS - tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS - lappend valnames_received $positionalidx - } - } - set positionalidx [expr {$start_position + $validx}] - } - #------------------------------------------ - - if {$leadermax == -1} { - #only check min - if {$num_leaders < $leadermin} { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected at least $leadermin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - } - } else { - if {$num_leaders < $leadermin || $num_leaders > $leadermax} { - if {$leadermin == $leadermax} { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected exactly $leadermin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - } else { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - } - } - } - - if {$valmax == -1} { - #only check min - if {$num_values < $valmin} { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $valmin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg - } - } else { - if {$num_values < $valmin || $num_values > $valmax} { - if {$valmin == $valmax} { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $valmin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg - } else { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $valmin and $valmax inclusive" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg - } - } - } - - #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options - - - #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 SHOULD? 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 - - #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? - #example timing difference: - #struct::set difference {x} {a b} - #normal interp 0.18 u2 vs safe interp 9.4us - #if {[llength [set missing [struct::set difference $OPT_REQUIRED $flagsreceived]]]} { - # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" - #} - #if {[llength [set missing [struct::set difference $VAL_REQUIRED $valnames_received]]]} { - # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" - #} - #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us - if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { - set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadermissing $missing received $leadernames_received] -argspecs $argspecs]] $msg - #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - if {[llength [set missing [punklib_ldiff $OPT_REQUIRED $flagsreceived]]]} { - set msg "Required option missing for %caller%. missing flags: '$missing' are marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list optionmissing $missing received $flagsreceived] -argspecs $argspecs]] $msg - #arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs - } - if {[llength [set missing [punklib_ldiff $VAL_REQUIRED $valnames_received]]]} { - set msg "Required value missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list valuemissing $missing received $valnames_received] -argspecs $argspecs]] $msg - #arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - - - #todo - truncate/summarize values in error messages - - #todo - allow defaults outside of choices/ranges - - #check types,ranges,choices - set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] - #set combined_defaults [tcl::dict::merge $VAL_DEFAULTS $OPT_DEFAULTS] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash - #puts "---opts_and_values:$opts_and_values" - #puts "---argstate:$argstate" - tcl::dict::for {argname v} $opts_and_values { - set thisarg [tcl::dict::get $argstate $argname] - #set thisarg_keys [tcl::dict::keys $thisarg] - set thisarg_checks [tcl::dict::get $arg_checks $argname] - set is_multiple [tcl::dict::get $thisarg -multiple] - set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] - set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] - set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] - set has_default [tcl::dict::exists $thisarg -default] - if {$has_default} { - set defaultval [tcl::dict::get $thisarg -default] - } - set type [tcl::dict::get $thisarg -type] - set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] - set regexprepass [tcl::dict::get $thisarg -regexprepass] - set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 - set validationtransform [tcl::dict::get $thisarg -validationtransform] - - - if {$is_multiple} { - set vlist $v - } else { - set vlist [list $v] - } - set vlist_original $vlist ;#retain for possible final strip_ansi - - #review - validationtransform - if {$is_validate_ansistripped} { - #validate_ansistripped 1 - package require punk::ansi - set vlist_check [list] - foreach e $vlist { - lappend vlist_check [punk::ansi::ansistrip $e] - } - } else { - #validate_ansistripped 0 - set vlist_check $vlist - } - - switch -- [Dict_getdef $thisarg -ARGTYPE unknown] { - leader { - set dname leaders_dict - set argclass "Leading argument" - } - option { - set dname opts - set argclass Option - } - value { - set dname values_dict - set argclass "Trailing argument" - } - default { - set dname "_unknown_" ;#NA - set argclass "Unknown argument" - } - } - #reduce our validation requirements by removing values which match defaultval or match -choices - #(could be -multiple with -choicerestriction 0 where some selections match and others don't) - if {$has_choices} { - #-choices must also work with -multiple - #todo -choicelabels - set choiceprefix [tcl::dict::get $thisarg -choiceprefix] - set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] - set choicerestricted [tcl::dict::get $thisarg -choicerestricted] - set choicemultiple [tcl::dict::get $thisarg -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set nocase [tcl::dict::get $thisarg -nocase] - set choices [Dict_getdef $thisarg -choices {}] - set choicegroups [Dict_getdef $thisarg -choicegroups {}] - set allchoices $choices - if {[dict size $choicegroups]} { - dict for {groupname groupmembers} $choicegroups { - lappend allchoices {*}$groupmembers - } - } - #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups - #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes - - - set idx 0 ;# - #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes - #assert llength $vlist == llength [dict get $dname $argname] - # (unless there was a default and the option wasn't specified) - set vlist_validate [list] - set vlist_check_validate [list] - foreach e $vlist e_check $vlist_check { - set allchoices_in_list 0 - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - #vlist and vlist_check can be list of lists if -multiple and -choicemultiple - #each e represents 0 or more choice selections - set c_list $e - set c_check_list $e_check - #todo? check if entire list matches default? - } else { - #only one choice at a time - ensure single entry in c_list c_check_list - set c_list [list $e] - set c_check_list [list $e_check] - } - - - #----------------------------------- - #fast fail on the wrong number of choices - if {[llength $c_list] < $choicemultiple_min} { - set msg "$argclass $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { - set msg "$argclass $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - #----------------------------------- - - set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list - foreach c $c_list c_check $c_check_list { - if {$nocase} { - set casemsg " (case insensitive)" - set choices_test [tcl::string::tolower $allchoices] - #Don't lcase the denylist - even in nocase mode! - #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] - set v_test [tcl::string::tolower $c_check] - } else { - set casemsg " (case sensitive)" - set v_test $c_check - set choices_test $allchoices - } - set choice_in_list 0 - set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? - if {!$matches_default} { - if {$choiceprefix} { - #can we handle empty string as a choice? It should just work - REVIEW/test - set choice_exact_match 0 - if {$c_check in $allchoices} { - #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing - set chosen $c_check - set choice_in_list 1 - set choice_exact_match 1 - } elseif {$v_test in $choices_test} { - #assert - if we're here, nocase must be true - #we know choice is present as full-length match except for case - #now we want to select the case from the choice list - not the supplied value - #we don't set choice_exact_match - because we will need to override the optimistic existing val below - #review - foreach avail [lsort -unique $allchoices] { - if {[string match -nocase $c $avail]} { - set chosen $avail - } - } - #assert chosen will always get set - set choice_in_list 1 - } else { - #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. - #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. - #in this block we can treat empty result from prefix match as a non-match - if {$nocase} { - #nocase implies that our entered value doesn't have to match case of choices - - #but we would still like to select the best match if there are case-dups. - #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete - # selecting Del will find Delete, del will match delete (and raise error) - # but DEL will also match delete rather than Delete - so again an error is raised. - #This is counterintuitive with -nocase - #This is probably such an edge case that best served with documentation as a feature-not-bug - #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? - #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. - - set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] - if {$bestmatch eq ""} { - set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] - #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing - set chosen [lsearch -inline -nocase $allchoices $chosen] - set choice_in_list [expr {$chosen ne ""}] - } else { - set chosen $bestmatch - set choice_in_list 1 - } - } else { - set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] - if {$chosen eq ""} { - set choice_in_list 0 - } else { - set choice_in_list 1 - } - } - #override choice_in_list if in deny list - #don't allow prefixing for elements from -choiceprefixdenylist - #we still use all elements to calculate the prefixes though - #review - case difference edge cases in choiceprefixdenylist !todo - if {$chosen in $choiceprefixdenylist} { - set choice_in_list 0 - set chosen "" - } - } - - #override the optimistic existing val - if {$choice_in_list && !$choice_exact_match} { - if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { - if {$is_multiple} { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $idx $chosen - tcl::dict::set $dname $argname $existing - } else { - tcl::dict::set $dname $argname $chosen - } - } else { - if {$is_multiple} { - set existing_all [tcl::dict::get [set $dname] $argname] - lset existing_all $idx $choice_idx $chosen - tcl::dict::set $dname $argname $existing_all - } else { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $choice_idx $chosen - tcl::dict::set $dname $argname $existing - } - } - } - } else { - #value as stored in $dname is ok - set choice_in_list [expr {$v_test in $choices_test}] - } - } - - if {!$choice_in_list && !$matches_default} { - if {!$choicerestricted} { - #if {$is_multiple} { - # set existing [tcl::dict::get [set $dname] $argname] - # lset existing $idx $v_test - # tcl::dict::set $dname $argname $existing - #} else { - # tcl::dict::set $dname $argname $v_test - #} - lappend vlist_validate $c - lappend vlist_check_validate $c_check - } else { - #unhappy path - if {$choiceprefix} { - set prefixmsg " (or a unique prefix of a value)" - } else { - set prefixmsg "" - } - #review: $c vs $c_check for -badval? - set msg "$argclass '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname - } - } - incr choice_idx - } - - incr idx - } - #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation - #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - - if {[llength $vlist] && $has_default} { - set vlist_validate [list] - set vlist_check_validate [list] - foreach c $vlist c_check $vlist_check { - #for -choicemultiple with default that could be a list use 'ni' ?? review - if {$c_check ne $defaultval} { - lappend vlist_validate $c - lappend vlist_check_validate $c - } - } - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - - #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups - #assert: our vlist & vlist_check lists have been reduced to remove those - if {[llength $vlist] && !$is_allow_ansi} { - #allow_ansi 0 - package require punk::ansi - #do not run ta::detect on a list - foreach e $vlist { - if {[punk::ansi::ta::detect $e]} { - set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - #puts "argname:$argname v:$v is_default:$is_default" - #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. - #arguments that are at their default are not subject to type and other checks - - #don't validate defaults or choices that matched - #puts "---> opts_and_values: $opts_and_values" - #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" - #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} - - #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups - #assert [llength $vlist] == [llength $vlist_check] - if {[llength $vlist]} { - switch -- $type { - literal { - foreach e $vlist { - if {$e ne $argname} { - set msg "$argclass '$argname' for %caller% requires literal value '$argname'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - } - } - } - any {} - list { - foreach e_check $vlist_check { - if {![tcl::string::is list -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[llength $e_check] < $checkval} { - set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[llength $e_check] > $checkval} { - set msg "$argclass '$argname for %caller% requires list with -maxsize $checkval. Received len:[llength $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - } - indexexpression { - foreach e_check $vlist_check { - if {[catch {lindex {} $e_check}]} { - set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - string - ansistring - globstring { - #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string - #we possibly don't want to always have to regex on things that don't pass the other more basic checks - # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) - # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) - # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead - # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function - # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) - # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail - - #todo? - way to validate both unstripped and stripped? - set pass_quick_list_e [list] - set pass_quick_list_e_check [list] - set remaining_e $vlist - set remaining_e_check $vlist_check - #review - order of -regexprepass and -regexprefail in original rawargs significant? - #for now -regexprepass always takes precedence - if {$regexprepass ne ""} { - foreach e $vlist e_check $vlist_check { - if {[regexp $regexprepass $e]} { - lappend pass_quick_list_e $e - lappend pass_quick_list_e_check $e_check - } - } - set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] - set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] - } - if {$regexprefail ne ""} { - foreach e $remaining_e e_check $remaining_e_check { - #puts "----> checking $e vs regex $regexprefail" - if {[regexp $regexprefail $e]} { - if {[tcl::dict::exists $thisarg -regexprefailmsg]} { - #review - %caller% ?? - set msg [tcl::dict::get $thisarg -regexprefailmsg] - } else { - set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" - } - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $e -argspecs $argspecs]] $msg - } - } - } - switch -- $type { - ansistring { - #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi - #.. so we need to look at the original values in $vlist not $vlist_check - - #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? - #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? - package require punk::ansi - foreach e $remaining_e { - if {![punk::ansi::ta::detect $e]} { - set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - } - } - } - globstring { - foreach e $remaining_e { - if {![regexp {[*?\[\]]} $e]} { - set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - } - } - } - } - - if {[tcl::dict::size $thisarg_checks]} { - foreach e_check $remaining_e_check { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[tcl::string::length $e_check] < $checkval} { - set msg "$argclass '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::string::length $e_check] > $checkval} { - set msg "$argclass '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - } - number { - #review - consider effects of Nan and Inf - #NaN can be considered as 'technically' a number (or at least a special numeric value) - lassign {} low high ;#set both empty - set has_range 0 - if {[tcl::dict::exists $thisarg -range]} { - lassign [tcl::dict::get $thisarg -range] low high - if {"$low$high" ne ""} { - set has_range 1 - } - } - foreach e $vlist e_check $vlist_check { - if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} { - set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - if {$has_range} { - if {[::tcl::mathfunc::isnan $e]} { - set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - if {$low eq ""} { - if {$e_check > $high} { - set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } elseif {$high eq ""} { - if {$e_check < $low} { - set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } else { - if {$e_check < $low || $e_check > $high} { - set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - int { - #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive - if {[tcl::dict::exists $thisarg -range]} { - lassign [tcl::dict::get $thisarg -range] low high - if {"$low$high" ne ""} { - if {$low eq ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - #lowside unspecified - check only high - if {$e_check > $high} { - set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } elseif {$high eq ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - #highside unspecified - check only low - if {$e_check < $low} { - set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } else { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - #high and low specified - if {$e_check < $low || $e_check > $high} { - set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } else { - foreach e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - double { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is double -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type double. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - if {[tcl::dict::size $thisarg_checks]} { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -range { - #todo - small-value double comparisons with error-margin? review - #todo - empty string for low or high - lassign $checkval low high - if {$e_check < $low || $e_check > $high} { - set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - bool { - foreach e_check $vlist_check { - if {![tcl::string::is boolean -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - dict { - foreach e_check $vlist_check { - if {[llength $e_check] %2 != 0} { - set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[tcl::dict::size $e_check] < $checkval} { - set msg "$argclass '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::dict::size $e_check] > $checkval} { - set msg "$argclass '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - } - alnum - - alpha - - ascii - - control - - digit - - graph - - lower - - print - - punct - - space - - upper - - wordchar - - xdigit { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is $type -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - file - - directory - - existingfile - - existingdirectory { - foreach e $vlist e_check $vlist_check { - #//review - we may need '?' char on windows - if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { - #what about special file names e.g on windows NUL ? - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - if {$type eq "existingfile"} { - foreach e $vlist e_check $vlist_check { - if {![file exists $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } elseif {$type eq "existingdirectory"} { - foreach e $vlist e_check $vlist_check { - if {![file isdirectory $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } - } - char { - #review - char vs unicode codepoint vs grapheme? - foreach e $vlist e_check $vlist_check { - if {[tcl::string::length $e_check] != 1} { - set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } - } - - } - - if {$is_strip_ansi} { - set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach - if {[tcl::dict::get $thisarg -multiple]} { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict $argname $stripped_list - } - option { - tcl::dict::set opts $argname $stripped_list - } - value { - tcl::dict::set values_dict $argname $stripped_list - } - } - } else { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict [lindex $stripped_list 0] - } - option { - tcl::dict::set opts $argname [lindex $stripped_list 0] - } - value { - tcl::dict::set values_dict [lindex $stripped_list 0] - } - } - } - } - } - - #maintain order of opts $opts values $values as caller may use lassign. - set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] - if {[llength $receivednames]} { - #flat zip of names with overall posn, including opts - #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] - set i -1 - set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] - } else { - set received_posns [list] - } - #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) - #(e.g using 'dict exists $received -flag') - # - but it can have duplicate keys when args/opts have -multiple 1 - #It is actually a list of paired elements - return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived multis $multisreceived] - } - - - proc forms {id} { - set spec [get_spec $id] - if {[dict size $spec]} { - return [dict get $spec form_names] - } else { - return [list] - } - } - lappend PUNKARGS [list { - @id -id ::punk::args::synopsis - @cmd -name punk::args::synopsis -help\ - "Return synopsis for each form of a command id - on separate lines. - If -form is given, supply only - the synopsis for that form. - " - @opts - -form -type string -default * - -return -type string -default full -choices {full summary dict} - @values -min 1 -max -1 - cmditem -multiple 1 -optional 0 - }] - proc synopsis {args} { - set argd [punk::args::parse $args withid ::punk::args::synopsis] - - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - if {$has_punkansi} { - set I [punk::ansi::a+ italic] - set RST [punk::ansi::a] - } else { - set I "" - set RST "" - } - - ##set form * - ##if {[lindex $args 0] eq "-form"} { - ## set arglist [lrange $args 2 end] - ## set form [lindex $args 1] - ##} else { - ## set arglist $args - ##} - ##if {[llength $arglist] == 0} { - ## error "punk::args::synopsis expected command id possibly with trailing subcommands/args" - ##} - ##set id [lindex $arglist 0] - ##set cmdargs [lrange $arglist 1 end] - - lassign [dict values $argd] leaders opts values - set form [dict get $opts -form] - set opt_return [dict get $opts -return] - set cmditems [dict get $values cmditem] - set id [lindex $cmditems 0] - set cmdargs [lrange $cmditems 1 end] - - - set spec [get_spec $id] - if {$spec eq ""} { - return - } - set form_names [dict get $spec form_names] - if {$form ne "*"} { - if {[string is integer -strict $form]} { - set f [lindex $form_names $form] - if {$f ne ""} { - set form_names [list $f] - } else { - set form_names [list] - } - } else { - if {$form in $form_names} { - set form_names [list $form] - } else { - set form_names [list] - } - } - } - - set SYND [dict create] - set syn "" - #todo - -multiple etc - foreach f $form_names { - set SYNLIST [list] - dict set SYND $f [list] - append syn "$id" - set forminfo [dict get $spec FORMS $f] - foreach argname [dict get $forminfo LEADER_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set ARGD [dict create argname $argname class leader] - if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - set display [lindex [dict get $arginfo -choices] 0] - } elseif {[dict get $arginfo -type] eq "literal"} { - set display $argname - } else { - set display $I$argname$RST - } - if {[dict get $arginfo -optional]} { - append syn " ?$display?" - } else { - append syn " $display" - } - dict set ARGD type [dict get $arginfo -type] - dict set ARGD optional [dict get $arginfo -optional] - dict set ARGD display $display - dict lappend SYND $f $ARGD - } - foreach argname [dict get $forminfo OPT_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set ARGD [dict create argname $argname class option] - set tp [dict get $arginfo -type] - if {[dict get $arginfo -optional]} { - if {[dict get $arginfo -multiple]} { - if {$tp eq "none"} { - set display "?$argname?..." - } else { - set display "?$argname <$tp>?..." - } - } else { - if {$tp eq "none"} { - set display "?$argname?" - } else { - set display "?$argname <$tp>?" - } - } - } else { - if {[dict get $arginfo -multiple]} { - if {$tp eq "none"} { - set display "$argname ?$argname...?" - } else { - set display "$argname <$tp> ?$argname <$tp>?..." - } - } else { - if {$tp eq "none"} { - set display $argname - } else { - set display "$argname <$tp>" - } - } - } - append syn " $display" - dict set ARGD type [dict get $arginfo -type] - dict set ARGD optional [dict get $arginfo -optional] - dict set ARGD display $display - dict lappend SYND $f $ARGD - } - foreach argname [dict get $forminfo VAL_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set ARGD [dict create argname $argname class value] - if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} { - if {[dict get $arginfo -multiple]} { - set display "?$I$argname$RST?..." - } else { - if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - set display "?[lindex [dict get $arginfo -choices] 0]?" - } elseif {[dict get $arginfo -type] eq "literal"} { - set display "?$argname?" - } else { - set display "?$I$argname$RST?" - } - } - } else { - if {[dict get $arginfo -multiple]} { - set display "$I$argname$RST ?$I$argname$RST?..." - } else { - if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - set display "[lindex [dict get $arginfo -choices] 0]" - } elseif {[dict get $arginfo -type] eq "literal"} { - set display $argname - } else { - set display "$I$argname$RST" - } - } - } - append syn " $display" - dict set ARGD type [dict get $arginfo -type] - dict set ARGD optional [dict get $arginfo -optional] - dict set ARGD display $display - dict lappend SYND $f $ARGD - } - append syn \n - } - switch -- $opt_return { - full { - return [string trim $syn \n] - } - summary { - set summary "" - dict for {form arglist} $SYND { - append summary $id - set class_state leader - set option_count 0 - set value_count 0 - foreach ainfo $arglist { - switch -- [dict get $ainfo class] { - leader { - append summary " [dict get $ainfo display]" - } - option { - incr option_count - } - value { - incr value_count - if {$class_state ne "value"} { - if {$option_count > 0} { - append summary " ?options ($option_count defined)?" - } - set class_state value - } - append summary " [dict get $ainfo display]" - } - } - } - if {$value_count == 0 && $option_count > 0} { - append summary " ?options ($option_count defined)?" - } - append summary \n - } - set summary [string trim $summary \n] - return $summary - } - dict { - return $SYND - } - } - } - - - lappend PUNKARGS [list { - @id -id ::punk::args::synopsis_summary - @cmd -name punk::args::synopsis_summary -help\ - "Reduce the width of a synopsis string - by coalescing options to ?options?... - synopsis string may be arbitrarily marked - up with ANSI codes." - @opts - @values -min 1 -max -1 - synopsis -multiple 0 -optional 0 - }] - proc synopsis_summary {args} { - set argd [punk::args::parse $args withid ::punk::args::synopsis_summary] - set synopsis [dict get $argd values synopsis] - set summary "" - foreach sline [split $synopsis \n] { - set sline [regsub -all {\s+} $sline " "] ;#normalize to single spacing only - review - set in_opt 0 - set line_out "" - set codestack [list] - set parts [punk::ansi::ta::split_codes_single $sline] - #basic - foreach {pt code} $parts { - set charlist [split $pt ""] - for {set i 0} {$i < [llength $charlist]} {incr i} { - set c [lindex $charlist $i] - - switch -- $c { - ? { - if {!$in_opt} { - set in_opt 1 - } else { - - } - } - " " { - if {!$in_opt} { - append line_out " " - } else { - set in_opt - } - } - default { - if {!$in_opt} { - append line_out $c - } - } - } - } - if {$code ne ""} { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set codestack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set codestack [list $code] - } elseif {[punk::ansi::codetype::is_sgr $code]} { - #basic simplification first - remove straight dupes - set dup_posns [lsearch -all -exact $codestack $code] ;#must be -exact because of square-bracket glob chars - set codestack [lremove $codestack {*}$dup_posns] - lappend codestack $code - } else { - #? ignore other ANSI codes? - } - } - } - if {[string match -* $plain_s] || [string match ?- $plain_s]} { - } - } - return $summary - } - - lappend PUNKARGS [list { - @id -id ::punk::args::TEST - @opts -optional 0 - -o1 -default 111 -help "opt 1 mandatory" - @opts -optional 1 - -o2 -default 222 -help "opt 2 optional" - @values -min 0 -max 1 - v -help\ - "v1 optional" - }] - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::lib { - variable PUNKARGS - tcl::namespace::export * - tcl::namespace::path [list [tcl::namespace::parent]] - #*** !doctools - #[subsection {Namespace punk::args::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 flatzip {l1 l2} { - concat {*}[lmap a $l1 b $l2 {list $a $b}] - } - - if {[info commands lseq] ne ""} { - #tcl 8.7+ lseq significantly faster, especially for larger ranges - #The internal rep can be an 'arithseries' with no string representation - proc zero_based_posns {count} { - if {$count < 1} {return} - lseq 0 $count-1 - } - } else { - proc zero_based_posns {count} { - if {$count < 1} {return} - lsearch -all [lrepeat $count 0] * - } - } - - #return list of single column-width marks - possibly with ansi - proc choiceinfo_marks {choice choiceinfodict} { - set marks [list] - if {[dict exists $choiceinfodict $choice]} { - set cinfo [dict get $choiceinfodict $choice] - foreach info $cinfo { - if {[lindex $info 0] eq "doctype"} { - switch -- [lindex $info 1] { - punkargs { - lappend marks [punk::ns::Cmark punkargs brightgreen] - } - ensemble { - lappend marks [punk::ns::Cmark ensemble brightyellow] - } - oo { - lappend marks [punk::ns::Cmark oo brightcyan] - } - ooc { - lappend marks [punk::ns::Cmark ooc cyan] - } - ooo { - lappend marks [punk::ns::Cmark ooo cyan] - } - native { - lappend marks [punk::ns::Cmark native] - } - unknown { - lappend marks [punk::ns::Cmark unknown brightred] - } - } - } - } - } - return $marks - } - - - #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 -1] in calling scope ${[lindex [set x] 0]} !} - lappend PUNKARGS [list { - @id -id ::punk::args::lib::tstr - @cmd -name punk::args::lib::tstr -help\ - "A rough equivalent of js template literals - - Substitutions: - \$\{$varName\} - \$\{[myCommand]\} - (when -allowcommands flag is given)" - -allowcommands -default 0 -type none -help\ - "If -allowcommands is present, placeholder can contain commands - e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" - -undent -default 1 -type boolean -help\ - "undent/dedent the template lines. - The longest common prefix of whitespace is removed" - -indent -default "" -type string -help\ - "String with which to indent the template - prior to substitution. - If -undent is enabled, that is performed - first, then the indent is applied." - -paramindents -default line -choices {none line position} -choicelabels { - line\ - " Use leading whitespace in - the line in which the - placeholder occurs." - position\ - " Use the position in - the line in which the - placeholder occurs." - none\ - " No indents applied to - subsequent placeholder value - lines. This will usually - result in text awkwardly - ragged unless the source code - has also been aligned with the - left margin or the value has - been manually padded." - } -help\ - "How indenting is done for subsequent lines in a - multi-line placeholder substitution value. - The 1st line or a single line value is always - placed at the placeholder. - paramindents are performed after the main - template has been indented/undented. - (indenting by position does not calculate - unicode double-wide or grapheme cluster widths) - " - #choicelabels indented by 1 char is clearer for -return string - and reasonable in table - -return -default string -choices {dict list string args}\ - -choicelabels { - dict\ - " Return a dict with keys - 'template', 'params' and - 'errors'" - string\ - " Return a single result - being the string with - placeholders substituted." - list\ - " Return a 2 element list. - The first is itself a list - of plaintext portions of the - template, split at each point - at which placeholders were - present. The second element - of the outer list is a list - of placeholder values if -eval - is 1, or a list of the raw - placeholder strings if -eval - is 0." - args\ - " Return a list where the first - element is a list of template - plaintext sections as per the - 'list' return mechanism, but the - placeholder items are individual - items in the returned list. - This can be useful when passing - the expanded result of a tstr - command to another function - which expects the placeholders - as individual arguments" - } - -eval -default 1 -type boolean -help\ - "Whether to evaluate the \$\{\} placeholders. - When -return is string, -eval should generally be set to 1. - For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. - contained variables in that case should be braced or whitespace separated, or the variable - name is likely to collide with surrounding text. - e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" - @values -min 0 -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 - e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} - - Escape sequences such as \\n and unicode escapes are processed within placeholders. - " - }] - - proc tstr {args} { - #Too hard to fully eat-our-own-dogfood from within punk::args package - # - we use punk::args within the unhappy path only - #set argd [punk::args::get_by_id ::punk::lib::tstr $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 opt_eval [dict get $argd opts -eval] - - set templatestring [lindex $args end] - set arglist [lrange $args 0 end-1] - set opts [dict create\ - -allowcommands 0\ - -undent 1\ - -indent ""\ - -paramindents line\ - -eval 1\ - -return string\ - ] - if {"-allowcommands" in $arglist} { - set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] - dict set opts -allowcommands 1 - } - if {[llength $arglist] % 2 != 0} { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr expected option/value pairs prior to last argument" - } - } - dict for {k v} $arglist { - set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] - switch -- $fullk { - -indent - -undent - -paramindents - -return - -eval { - dict set opts $fullk $v - } - default { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" - } - } - } - } - set opt_allowcommands [dict get $opts -allowcommands] - set opt_paramindents [dict get $opts -paramindents] - set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] - if {$test_paramindents ni {none line position}} { - error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." - } - set opt_paramindents $test_paramindents - set opt_return [dict get $opts -return] - set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] - if {$opt_return eq ""} { - } - set opt_eval [dict get $opts -eval] - - - set nocommands "-nocommands" - if {$opt_allowcommands == 1} { - set nocommands "" - } - - set opt_undent [dict get $opts -undent] - if {$opt_undent} { - set templatestring [punk::args::lib::undent $templatestring] - } - set opt_indent [dict get $opts -indent] - if {$opt_indent ne ""} { - set templatestring [punk::args::lib::indent $templatestring $opt_indent] - } - - #set parts [_tstr_split $templatestring] - if {[string first \$\{ $templatestring] < 0} { - set parts [list $templatestring] - } else { - set parts [_parse_tstr_parts $templatestring] - } - set textchunks [list] - #set expressions [list] - set params [list] - set idx 0 - set errors [dict create] - set lastline "" ;#todo - first line has placeholder? - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach {pt expression} $parts { - lappend textchunks $pt - incr idx ;#pt incr - - #ignore last expression - if {$idx == [llength $parts]} { - break - } - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - #lappend expressions $expression - #---------------------- - #REVIEW - JMN - #TODO - debug punk::args loading of @dynamic defs - #puts "-- $expression" - #---------------------- - #brk1 - literal newline not {\n} - set leader "" - if {[set brk1 [string first \n $expression]] >= 0} { - #undent left of paramstart only for lines of expression that arent on opening ${..} line - set tail [string range $expression $brk1+1 end] - set leader [string repeat " " [string length $lastline]] - set undentedtail [punk::args::lib::undentleader $tail $leader] - #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] - set expression "[string range $expression 0 $brk1]$undentedtail" - } - if {$opt_eval} { - if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { - lappend params [string cat \$\{ $expression \}] - dict set errors [expr {[llength $params]-1}] $result - } else { - set result [string map [list \n "\n$leader"] $result] - lappend params $result - } - #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] - } else { - lappend params [subst -nocommands -novariables $expression] - } - append lastline [lindex $params end] ;#for current expression's position calc - - incr idx ;#expression incr - } - - if {$opt_return eq "dict"} { - return [dict create template $textchunks params $params errors $errors] - } - if {[dict size $errors]} { - set einfo "" - dict for {i e} $errors { - append einfo "parameter $i error: $e" \n - } - #REVIEW!!! - #TODO - fix - #puts stderr "tstr errors:\n$einfo\n" - } - - switch -- $opt_return { - list { - return [list $textchunks $params] - } - args { - #see example in tstr_test_one - return [list $textchunks {*}$params] - } - string { - #todo - flag to disable indent-matching behaviour for multiline param? - set out "" - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach pt $textchunks param $params { - if {$opt_paramindents eq "none"} { - append out $pt $param - } else { - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - if {$opt_paramindents eq "line"} { - regexp {(\s*).*} $lastline _all lastindent - } else { - #position - #TODO - detect if there are grapheme clusters - #This regsub doesn't properly space unicode double-wide chars or clusters - set lastindent "[regsub -all {\S} $lastline " "] " - } - if {$lastindent ne ""} { - set paramlines [split $param \n] - if {[llength $paramlines] == 1} { - append out $pt $param - } else { - append out $pt [lindex $paramlines 0] - foreach nextline [lrange $paramlines 1 end] { - append out \n $lastindent $nextline - } - } - } else { - append out $pt $param - } - append lastline $param - } - } - return $out - } - } - } - #test single placeholder tstr args where single placeholder must be an int - proc tstr_test_one {args} { - set argd [punk::args::parse $args withdef { - @cmd -name ::punk::args::lib::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 -return args {Select * from table where id = \$\{$id\} and etc... ;}] - } - - @values -min 2 -max 2 - template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - - but the tstr call in the example 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} - }] - 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]] ""] - set result [string cat [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 dollar sign - 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]] - } - - #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. - proc indent {text {prefix " "}} { - set result [list] - foreach line [split $text \n] { - if {[string trim $line] eq ""} { - lappend result "" - } else { - lappend result $prefix[string trimright $line] - } - } - return [join $result \n] - } - #dedent? - proc undent {text} { - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - regexp {^([\t ]*)} $lcp _m lcp - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - - #hacky - proc undentleader {text leader} { - #leader usually whitespace - but doesn't have to be - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - lappend nonblank "${leader}!!" - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - #regexp {^([\t ]*)} $lcp _m lcp - #lcp can be shorter than leader - set lcp [string range $lcp 0 [string length $leader]-1] - - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - #A version of textutil::string::longestCommonPrefixList - proc longestCommonPrefix {items} { - if {[llength $items] <= 1} { - return [lindex $items 0] - } - set items [lsort $items[unset items]] - set min [lindex $items 0] - set max [lindex $items end] - #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) - #(sort order nothing to do with length - e.g min may be longer than max) - if {[string length $min] > [string length $max]} { - set temp $min - set min $max - set max $temp - } - set n [string length $min] - set prefix "" - set i -1 - while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { - append prefix $c - } - return $prefix - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] -} - -tcl::namespace::eval punk::args::argdocbase { - namespace export * - #use a? to test and create literal ansi here rather than relying on punk::ansi package presence - #e.g - #% a? bold - #- bold │SGR 1│sample│␛[1msample - #- ──────┼─────┼──────┼────────── - #- RESULT│ │sample│␛[1msample - proc B {} {return \x1b\[1m} ;#a+ bold - proc N {} {return \x1b\[22m} ;#a+ normal - proc I {} {return \x1b\[3m} ;#a+ italic - proc NI {} {return \x1b\[23m} ;#a+ noitalic - -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::package { - variable PUNKARGS - lappend PUNKARGS [list { - @dynamic - @id -id "::punk::args::package::standard_about" - @cmd -name "%pkg%::about" -help\ - "About %pkg% - ... - " - -package_about_namespace -type string -optional 0 -help\ - "Namespace containing the package about procedures - Must contain " - -return\ - -type string\ - -default table\ - -choices {string table tableobject}\ - -choicelabels { - string\ - "A basic text layout" - table\ - "layout in table borders - (requires package: textblock)" - tableobject\ - "textblock::class::table object instance" - }\ - -help\ - "Choose the return type of the 'about' information" - topic -optional 1\ - -nocase 1\ - -default {*}\ - -choices {Description License Version Contact *}\ - -choicerestricted 0\ - -choicelabels { - - }\ - -multiple 1\ - -help\ - "Topic to display. Omit or specify as * to see all. - If * is included with explicit topics, * represents - the remaining unmentioned topics." - }] - proc standard_about {args} { - set argd [punk::args::parse $args withid ::punk::args::package::standard_about] - lassign [dict values $argd] leaders OPTS values received - - set pkgns [dict get $OPTS -package_about_namespace] - if {[info commands ${pkgns}::package_name] eq ""} { - error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" - } - set pkgname [${pkgns}::package_name] - - set opt_return [dict get $OPTS -return] - set all_topics [${pkgns}::about_topics] - if {![dict exists $received topic]} { - set topics $all_topics - } else { - # * represents all remaining topics not explicitly mentioned. - set val_topics [dict get $values topic] ;#if -multiple is true, this is a list - set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] - set topics [list] - foreach t $val_topics { - if {$t eq "*"} { - foreach a $all_topics { - if {$a ni $explicit_topics} { - lappend topics $a - } - } - } else { - lappend topics $t - } - } - } - if {$opt_return ne "string"} { - package require textblock ;#table support - set is_table 1 - set title [string cat {[} $pkgname {]} ] - set t [textblock::class::table new -title $title] - $t configure -frametype double -minwidth [expr {[string length $title]+2}] - - } else { - set topiclens [lmap t $topics {string length $t}] - set widest_topic [tcl::mathfunc::max {*}$topiclens] - set is_table 0 - set about "$pkgname\n" - append about [string repeat - $widest_topic] \n - } - foreach topic $topics { - if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { - set topic_contents [::${pkgns}::get_topic_$topic] - } else { - set topic_contents "" - } - if {!$is_table} { - set content_lines [split $topic_contents \n] - append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n - foreach ln [lrange $content_lines 1 end] { - append about [format %-${widest_topic}s ""] " " $ln \n - } - } else { - $t add_row [list $topic $topic_contents] - } - } - - if {!$is_table} { - return $about - } else { - if {$opt_return eq "tableobject"} { - return $t - } - set result [$t print] - $t destroy - return $result - } - } - -} - -#usually we would directly call arg definitions near the defining proc, -# so that the proc could directly use the definition in its parsing. -# -#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. -#arguably it may be more processor-cache-efficient to do together like this anyway. - -#can't do this here? - as there is circular dependency with punk::lib -#tcl::namespace::eval punk::args { -# foreach deflist $PUNKARGS { -# punk::args::define {*}$deflist -# } -# set PUNKARGS "" -#} - -lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -tcl::namespace::eval punk::args::system { - #*** !doctools - #[subsection {Namespace punk::args::system}] - #[para] Internal functions that are not part of the API - - #dict get value with default wrapper for tcl 8.6 - if {[info commands ::tcl::dict::getdef] eq ""} { - proc Dict_getdef {dictValue args} { - set keys [lrange $args 0 end-1] - if {[tcl::dict::exists $dictValue {*}$keys]} { - return [tcl::dict::get $dictValue {*}$keys] - } else { - return [lindex $args end] - } - } - } else { - #we pay a minor perf penalty for the wrap - interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef - } - - #name to reflect maintenance - home is punk::lib::ldiff - proc punklib_ldiff {fromlist removeitems} { - if {[llength $removeitems] == 0} {return $fromlist} - set result {} - foreach item $fromlist { - if {$item ni $removeitems} { - lappend result $item - } - } - return $result - } - -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::args [tcl::namespace::eval punk::args { - tcl::namespace::path {::punk::args::lib ::punk::args::system} - variable pkg punk::args - variable version - set version 0.1.7 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.8.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.8.tm deleted file mode 100644 index c17ecc2c..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.8.tm +++ /dev/null @@ -1,7213 +0,0 @@ -# -*- 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: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.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 punk::args 0.1.8 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.1.8] -#[copyright "2024"] -#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] -#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] -#[require punk::args] -#[keywords module proc args arguments parse] -#[description] -#[para]Utilities for parsing proc args - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). -#[para] overview of punk::args -#[subsection Concepts] -#[para]There are 2 main conventions for parsing a proc args list -#[list_begin enumerated] -#[enum] -#[para]leading option-value pairs and flags followed by a list of values (Tcl style) -#[enum] -#[para]leading list of values followed by option-value pairs and flags (Tk style) -#[list_end] -#[para]There are exceptions in both Tcl and Tk commands regarding this ordering -#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style -#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] -#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. -#[para] -#[para]The basic principle is that a call to punk::args::parse is made near the beginning of the proc with a cacheable argument defining the parameters e.g -#[example { -# proc dofilestuff {args} { -# lassign [dict values [punk::args::parse $args withdef { -# @cmd -help "do some stuff with files e.g dofilestuff " -# @opts -type string -# #comment lines ok -# -directory -default "" -# -translation -default binary -# #setting -type none indicates a flag that doesn't take a value (solo flag) -# -nocomplain -type none -# @values -min 1 -max -1 -# }]] leaders opts values -# -# puts "translation is [dict get $opts -translation]" -# foreach f [dict values $values] { -# puts "doing stuff with file: $f" -# } -# } -#}] -#[para]The lines beginning with @ are usually optional in most cases and can be used to set defaults and some extra controls -#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values -#[para]valid @ lines being with @cmd @leaders @opts @values -#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. -#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. -#[para]e.g the result from the punk::args::parse call above may be something like: -#[para] leaders {} opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} -#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments -#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments -#[para]This could also be implemented entirely using args - and the @leaders category of arguments -#[example { -# proc dofilestuff {category args} { -# lassign [dict values [punk::args::parse $args withdef { -# @id -id ::dofilestuff -# -directory -default "" -# -translation -default binary -# -nocomplain -type none -# @values -min 2 -max 2 -# fileA -type existingfile 1 -# fileB -type existingfile 1 -# }]] leaders opts values -# puts "$category fileA: [dict get $values fileA]" -# puts "$category fileB: [dict get $values fileB]" -# } -#}] -#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 -#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored -#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, -#[para] or an additional call could be made to punk::args e.g -#[example { -# punk::args::parse [list $category $another_leading_arg] withdef { -# category -choices {cat1 cat2 cat3} -# another_leading_arg -type boolean -# } -#}] - -#*** !doctools -#[subsection Notes] -#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. -#[para] -#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. -#For functions that are part of an API a package may be more suitable. -#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) -#[example { -# proc test_switch {args} { -# set opts [dict create\\ -# -return "object"\\ -# -frametype "heavy"\\ -# -show_edge 1\\ -# -show_seps 0\\ -# -x a\\ -# -y b\\ -# -z c\\ -# -1 1\\ -# -2 2\\ -# -3 3\\ -# ] -# foreach {k v} $args { -# switch -- $k { -# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { -# dict set opts $k $v -# } -# default { -# error "unrecognised option '$k'. Known options [dict keys $opts]" -# } -# } -# } -# return $opts -# } -#}] -#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. -#[para] -# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. -# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. -#[para]use punk::lib::show_jump_tables to verify that a jump table exists. -#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous -#[example { -# proc test_prefix {args} { -# set opts [dict create\ -# -return string\ -# -frametype \uFFEF\ -# -show_edge \uFFEF\ -# -show_seps \uFFEF\ -# -x a\ -# -y b\ -# -z c\ -# -1 1\ -# -2 2\ -# -3 3\ -# ] -# if {[llength $args]} { -# set knownflags [dict keys $opts] -# } -# foreach {k v} $args { -# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v -# } -# return $opts -# } -#}] -#[para]There are many alternative args parsing packages a few of which are listed here. -#[list_begin enumerated] -#[enum]argp (pure tcl) -#[enum]parse_args (c implementation) -#[enum]argparse (pure tcl *) -#[enum]cmdline (pure tcl) -#[enum]opt (pure tcl) distributed with Tcl but considered deprecated -#[enum]The tcllib set of TEPAM modules (pure tcl) -#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. -#[list_end] -#[para] (* c implementation planned/proposed) -#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. -#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences -#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. -#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. -#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. -#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. -#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -#All ensemble commands are slower in a safe interp as they aren't compiled the same way -#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 -#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. -#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) -#ensembles: array binary clock dict info namespace string -#possibly file too, although that is generally hidden/modified in a safe interp -#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc -#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::args -#[list_begin itemized] -package require Tcl 8.6- -#optional? punk::trie -#optional? punk::textblock -#*** !doctools -#[item] [package {Tcl 8.6-}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -tcl::namespace::eval punk::args::register { - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] cooperative namespace punk::args::register - #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded - #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. - #[list_begin definitions] - - #Although the actual punk::args::define calls are not too sluggish, there could be *many*. - #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, - #especially since a fair proportion may be for documentation purposes rather than parsing args. - - # -- --- --- --- --- --- --- --- - #cooperative with packages that define some punk args but do so lazily - #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first - variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective - if {![info exists ::punk::args::register::NAMESPACES]} { - set ::punk::args::register::NAMESPACES [list] - } - # -- --- --- --- --- --- --- --- - - variable loaded_packages - if {![info exists loaded_packages]} { - set loaded_packages [list] ;#fully loaded - } - variable loaded_info - if {![info exists loaded_info]} { - set loaded_info [dict create] ;#time - } - variable scanned_packages - if {![info exists scanned_packages]} { - set scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages - } - variable scanned_info ;#time and idcount - if {![info exists scanned_info]} { - set scanned_info [dict create] - } - #some packages, e.g punk::args::tclcore document other namespaces. - #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources - variable namespace_docpackages - if {![info exists namespace_docpackages]} { - set namespace_docpackages [dict create] - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::register ---}] -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args { - - - variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. - - tcl::namespace::export {[a-z]*} - variable rawdef_cache - if {![info exists rawdef_cache]} { - set rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} - } - variable id_cache_rawdef - if {![info exists id_cache_rawdef]} { - set id_cache_rawdef [tcl::dict::create] - } - variable id_cache_spec - if {![info exists id_cache_spec]} { - set id_cache_spec [tcl::dict::create] - } - - variable argdefcache_unresolved - if {![info exists argdefcache_unresolved]} { - set argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) - } - - variable argdata_cache - if {![info exists argdata_cache]} { - set argdata_cache [tcl::dict::create] - } - - variable id_counter - if {![info exists id_counter]} { - set id_counter 0 - } - - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] Core API functions for punk::args - #[list_begin definitions] - - #todo - some sort of punk::args::cherrypick operation to get spec from an existing set - #todo - doctools output from definition - - - - - #todo? -synonym/alias ? (applies to opts only not values) - #e.g -background -aliases {-bg} -default White - #review - how to make work with trie prefix - #e.g - # -corner -aliases {-corners} - # -centre -aliases {-center -middle} - #We mightn't want the prefix to be longer just because of an alias - #we should get -co -ce and -m from the above as abbreviations - - set map [list %G% \x1b\[32m %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] - - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::define - #todo @preamble -help "move large block outside of table?" - @cmd -name punk::args::define -help\ - "Accepts a line-based definition of command arguments. - The definition can be supplied as a single text block or multiple as described - in the help information for 'text' below. - - Returns an id which is a key to the stored definition. - The id is taken from the supplied definition's @id -id line, or is an - automatically created id of the form 'autoid_'. - - At the time define is called - just the raw text arguments are stored for the id. - When the id is first used, for example with 'punk::args::parse $args withid $id', - the raw definition is parsed into a stored specifications dictionary. - - This specifications dictionary is structured for (optional) use within commands to - parse and validate the arguments - and is also used when retrieving definitions - (or parts thereof) for re-use. - - This can be used purely for documentation or called within a function to parse a mix - of leading values, switches/flags and trailing values. - - The overhead is favourably comparable with other argument processors - but none are - as fast as minimal code with a switch statement. For toplevel commands where a few - 10s of microseconds is immaterial, the validation and automated error formatting in - a table can be well worthwhile. For inner procs requiring utmost speed, the call can - be made only on the unhappy path when basic processing determines a mismatch - or it - can be left entirely as documentation for interactive use with: i ... - and for synopsis generation with: s ... - - The definition should usually contain an initial line of the form: @id -id ::somecmd - - Blank lines are ignored at the top level, ie if they are not part of another structure. - Similarly - lines at the top level beginning with the # character are ignored. - All other toplevel lines must consist of a leading word followed by paired arguments. - The arguments can be spread over multiple lines and contain lines of near-arbitrary - text if they are properly braced or double quoted and Tcl escaping for inner quotes - or unbalanced braces is maintained. - The line continuation character - (\\ at the end of the line) can be used to continue the set of arguments for - a leading word. - Leading words beginning with the @ character are directives controlling argument - parsing, defaults for subsequent arguments, and help display. - directives include: - %B%@id%N% ?opt val...? - directive-options: -id - %B%@cmd%N% ?opt val...? - directive-options: -name -help - %B%@leaders%N% ?opt val...? - (used for leading args that come before switches/opts) - directive-options: -min -max -unnamed - (also accepts options as defaults for subsequent arguments) - %B%@opts%N% ?opt val...? - directive-options: -any|-arbitrary - %B%@values%N% ?opt val...? - (used for trailing args that come after switches/opts) - directive-options: -min -max -unnamed - (also accepts options as defaults for subsequent arguments) - %B%@form%N% ?opt val...? - (used for commands with multiple forms) - directive-options: -form -synopsis - The -synopsis value allows overriding the auto-calculated - synopsis. - %B%@formdisplay%N% ?opt val...? - directive-options: -header (text for header row of table) - -body (override autogenerated arg info for form) - %B%@doc%N% ?opt val...? - directive-options: -name -url - %B%@seealso%N% ?opt val...? - directive-options: -name -url (for footer - unimplemented) - - Some other options normally present on custom arguments are available - to use with the @leaders @opts @values directives to set defaults - for subsequent lines that represent your custom arguments. - These 3 directives should occur in exactly this order - but can be - repeated with custom argument lines interspersed. - - An @id line can only appear once and should be the first item. - For the commandline usage to be displayed either on parsing error - or using the i .. function - an @id with -id is needed. - - All directives can be omitted, in which case every line represents - a custom leader, value or option. - All will be leaders by default if no options defined. - If options are defined (by naming with leading dash, or explicitly - specifying @opts) then the definitions prior to the options will be - categorised as leaders, and those following the options will be - categorised as values. - - Custom arguments are defined by using any word at the start of a - line that doesn't begin with @ or - - (except that adding an additionl @ escapes this restriction so - that @@somearg becomes an argument named @somearg) - - custom leading args, switches/options (names starting with -) - and trailing values also take spec-options: - - -type - defaults to string. If no other restrictions - are specified, choosing string does the least validation. - recognised types: - int|integer - number - list - indexexpression - dict - double - bool|boolean - char - file - directory - ansistring - globstring - (any of the types accepted by 'string is') - - The above all perform some validation checks - - string - (also any of the 'string is' types such as - xdigit, graph, punct, lower etc) - any - none - (used for switches only. Indicates this is - a 'solo' flag ie accepts no value) - - and more.. (todo - document here) - - -optional - (defaults to true for flags/switches false otherwise) - For non flag/switch arguments - all arguments with - -optional true must sit consecutively within their group. - ie all optional leader arguments must be together, and all - optional value arguments must be together. Furthermore, - specifying both optional leaders and optional values will - often lead to ambiguous parsing results. Currently, all - optional non-flg/switch arguments should be either at the - trailing end of leaders or the trailing end of values. - Further unambiguous arrangements of optional args may be - made in future - but are currently considered 'unsupported' - -default - -multiple (for leaders & values defines whether - subsequent received values are stored against the same - argument name - only applies to final leader OR final value) - (for options/flags this allows the opt-val pair or solo - flag to appear multiple times - not necessarily contiguously) - -choices {} - A list of allowable values for an argument. - The -default value doesn't have to be in the list. - If a -type is specified - it doesn't apply to choice members. - It will only be used for validation if the -choicerestricted - option is set to false. If all choices are specified in values - within the -choicegroups dict, it is not necessary to specify them - in the -choices list. It is effectively a simpler form of - specifying choices when no grouping is required. It is fine to - use both -choices and -choicegroups e.g specifying all in -choices - and then including only some that need grouping in -choicegroups. - -choicelabels {} - keys are the values/argument names from -choices (or equivalently - members of value entries from the -choicegroups dict) - The values in the choicelabels dict are text values, possibly - containing newlines, that are displayed below each choice. - This is commonly a very basic summary of the choice. In the - case of a subcommand it may be a usage synopsis for further - arguments. - -choicerestricted - Whether values not specified in -choices or -choicegroups are - allowed. Defaults to true. - -choiceprefix - This specifies whether unique prefixes are able to be used - instead of the complete string. This is calculated using - tcl::prefix::match - and will display in the autogenerated - usage output. Defaults to true. - -choiceprefixdenylist {} - These choices should match exactly a choice entry in one of - the settings -choices or -choicegroups. - These will still be used in prefix calculation - but the full - choice argument must be entered to select the choice. - -choiceprefixreservelist {} - These choices are additional values used in prefix calculation. - The values will not be added to the list of available choices. - -choicegroups {} - Generally this would be used instead of -choices to allow - usage display of choices grouped by some name (or the empty - string for 'ungrouped' items which appear first). - See for example the output if 'i zlib' where choices of the - next subcommand are grouped by the names compression,channel, - streaming and checksumming. The -choices list is equivalent - to a -choicegroups dict entry where the key (groupname) is - the empty string. Both may be specified, in which case the - final list of available choices will be a union of the listed - values in -choices and the values from each choice group. - Choice values specified in -choices are effectively ungrouped - unless overridden by placing them in a choicegroup. - -choicemultiple (default {1 1}) - is a pair representing min and max number of choices - that can be present in the value. - If is a single integer it is equivalent to a - specified with the same integer for both min and max. - Max of -1 represents no upper limit. - If allows more than one choice the value is a list - consisting of items in the choices made available through - entries in -choices/-choicegroups. - -minsize (type dependant) - -maxsize (type dependant) - -range (type dependant) - - - " - -dynamic -type boolean -default 0 -help\ - "If -dynamic is true, tstr interpolations of the form \$\{\$var\} - are re-evaluated on each call. - If the definition is being used not just as documentation, but is also - used within the function to parse args, e.g using punk::args::get_by_id, - then it should be noted that there is a slight performance penalty for the - dynamic case. - It is often not significant, perhaps depending on what vars/commands are - used but -dynamic true might be less desirable if the command is used in - inner loops in more performance-sensitive code. - " - @values -min 1 -max -1 - text -type string -multiple 1 -help\ - {Block(s) of text representing the argument definition for a command. - At least one must be supplied. If multiple, they are joined together with \n. - Using multiple text arguments may be useful to mix curly-braced and double-quoted - strings to have finer control over interpolation when defining arguments. - (this can also be handy for sections that pull resolved definition lines - from existing definitions (by id) for re-use of argument specifications and help text) - - e.g the following definition passes 2 blocks as text arguments - ${[punk::args::tclcore::argdoc::example { - punk::args::define { - @id -id ::myns::myfunc - @cmd -name myns::myfunc -help\ - "Description of command" - - %G%#The following option defines an option-value pair%R% - %G%#It may have aliases by separating them with a pipe |%R% - -fg|-foreground -default blah -type string -help\ - "In the result dict returned by punk::args::parse - the value used in the opts key will always be the last - entry, in this case -foreground" - %G%#The following option defines a flag style option (solo)%R% - -flag1 -default 0 -type none -help\ - "Info about flag1 - subsequent help lines auto-dedented by whitespace to left - of corresponding record start (in this case -flag1) - + first 4 spaces if they are all present. - This line has no extra indent relative to first line 'Info about flag1' - This line indented a further 6 chars" - - @values -min 1 -max -1 - %G%#Items that don't begin with * or - are value definitions%R% - v1 -type integer -default 0 - thinglist -type string -multiple 1 - } "@doc -name Manpage: -url [myfunc_manpage_geturl myns::myfunc]"}]} - } - }]] - - proc New_command_form {name} { - #probably faster to inline a literal dict create in the proc than to use a namespace variable - set leaderspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - -ensembleparameter 0\ - ] - set optspec_defaults [tcl::dict::create\ - -type string\ - -optional 1\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - -prefix 1\ - ] - set valspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - - #form record can have running entries such as 'argspace' that aren't given to arg parser - #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict - return [dict create\ - argspace "leaders"\ - ARG_INFO [tcl::dict::create]\ - ARG_CHECKS [tcl::dict::create]\ - LEADER_DEFAULTS [tcl::dict::create]\ - LEADER_REQUIRED [list]\ - LEADER_NAMES [list]\ - LEADER_MIN ""\ - LEADER_MAX ""\ - LEADER_UNNAMED false\ - LEADERSPEC_DEFAULTS $leaderspec_defaults\ - LEADER_CHECKS_DEFAULTS {}\ - OPT_DEFAULTS [tcl::dict::create]\ - OPT_REQUIRED [list]\ - OPT_NAMES [list]\ - OPT_ANY 0\ - OPT_MIN ""\ - OPT_MAX ""\ - OPT_SOLOS {}\ - OPTSPEC_DEFAULTS $optspec_defaults\ - OPT_CHECKS_DEFAULTS {}\ - VAL_DEFAULTS [tcl::dict::create]\ - VAL_REQUIRED [list]\ - VAL_NAMES [list]\ - VAL_MIN ""\ - VAL_MAX ""\ - VAL_UNNAMED false\ - VALSPEC_DEFAULTS $valspec_defaults\ - VAL_CHECKS_DEFAULTS {}\ - FORMDISPLAY [tcl::dict::create]\ - ] - - } - - proc errorstyle {args} { - #set or query the running config -errorstyle - #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? - #values: - #debug, enhanced, standard, basic, minimal - error todo - } - proc define {args} { - variable rawdef_cache - variable id_cache_rawdef - variable argdata_cache - if {[dict exists $rawdef_cache $args]} { - return [dict get [dict get $rawdef_cache $args] -id] - } else { - set id [rawdef_id $args] - if {[id_exists $id]} { - #we seem to be re-creating a previously defined id... - #clear any existing caches for this id - puts stderr "punk::args::define Redefinition of id:$id - clearing existing data" - - #dict unset argdata_cache $prevraw ;#silently does nothing if key not present - dict for {k v} $argdata_cache { - if {[dict get $v id] eq $id} { - dict unset argdata_cache $k - } - } - dict for {k v} $rawdef_cache { - if {[dict get $v -id] eq $id} { - dict unset rawdef_cache $k - } - } - dict unset id_cache_rawdef $id - } - set is_dynamic [rawdef_is_dynamic $args] - set defspace [uplevel 1 {::namespace current}] - dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic -defspace $defspace] - dict set id_cache_rawdef $id $args - return $id - } - } - - proc idquery_info {id} { - variable id_cache_rawdef - variable rawdef_cache - if {[dict exists $id_cache_rawdef $id]} { - set sep [string repeat - 40] - set rawdef [dict get $id_cache_rawdef $id] - if {[dict exists $rawdef_cache $rawdef]} { - set idinfo [dict get $rawdef_cache $rawdef] - } else { - set idinfo "" - } - set result "raw definition:" - append result \n $sep - append result \n $rawdef - append result \n $sep - append result \n "id info:" - append result \n $idinfo - append result \n $sep - variable argdata_cache - #lsearch -stride not avail (or buggy) in some 8.6 interps - search manually for now (2025). todo - modernize some time after Tcl 9.0/9.1 more widespread.(2027?) - #check for and report if id is present multiple times - set argdata_records [list] - dict for {k v} $argdata_cache { - if {[dict get $v id] eq $id} { - if {$k eq $rawdef} { - lappend argdata_records [list 1 $k $v] - } else { - lappend argdata_records [list 0 $k $v] - } - } - } - append result \n "argdata cache:" - if {![llength $argdata_records]} { - append result \n "(not present)" - } else { - append result \n "present [llength $argdata_records] time(s)" - foreach r $argdata_records { - lassign $r match k v - if {$match} { - append result \n " - present with same rawdef key" - } else { - append result \n " - present with different rawdef key" - append result \n " [punk::lib::indent $k { }]" - } - } - if {[llength $argdata_records] > 1} { - append result \n "*more than one record was not expected - review*" - } - } - append result \n $sep - return $result - } - } - - proc define2 {args} { - dict get [resolve {*}$args] id - } - - proc resolve {args} { - variable rawdef_cache - variable id_cache_rawdef - set defspace "" - if {[dict exists $rawdef_cache $args]} { - set cinfo [dict get $rawdef_cache $args] - set id [dict get $cinfo -id] - set is_dynamic [dict get $cinfo -dynamic] - if {[dict exists $cinfo -defspace]} { - set defspace [dict get $cinfo -defspace] - } - } else { - #should we really be resolving something that hasn't been defined? - set id [rawdef_id $args] - puts stderr "Warning: punk::args::resolve called with undefined id:$id" - set is_dynamic [rawdef_is_dynamic $args] - dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] - dict set id_cache_rawdef $id $args - } - - - variable argdata_cache - variable argdefcache_unresolved - - - set cache_key $args - #ideally we would use a fast hash algorithm to produce a short key with low collision probability. - #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) - #review - check if there is a built-into-tcl way to do this quickly - #for now we will just key using the whole string - #performance seems ok - memory usage probably not ideal - #quote from DKF 2021 - #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. - #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. - #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. - #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). - #> If dealing with very large amounts of data, using a database is probably a good plan. - - set textargs $args - if {![llength $args]} { - punk::args::get_by_id ::punk::args::define {} - return - } - #if {[lindex $args 0] eq "-dynamic"} { - # set is_dynamic [lindex $args 1] - # set textargs [lrange $args 2 end] - #} - - #experimental - set LVL 2 - - if {!$is_dynamic} { - if {[tcl::dict::exists $argdata_cache $cache_key]} { - return [tcl::dict::get $argdata_cache $cache_key] - } - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - if {[string first \$\{ $optionspecs] > 0} { - if {$defspace ne ""} { - #normal/desired case - #set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -paramindents none -allowcommands $optionspecs]] - } else { - #todo - deprecate/stop from happening? - puts stderr "punk::args::resolve calling tstr for id:$id with no known definition space (-defspace empty)" - set optionspecs [uplevel $LVL [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } - } - } else { - - if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { - set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel $LVL [list ::subst $param]] - } - } else { - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - #dynamic - double substitution required. - #e.g - # set DYN_CHOICES {${[::somewhere::get_choice_list]}} - # set RED [punk::ansi::a+ bold red] - # set RST [punk::ansi::a] - # punk::args::define { - # -arg -choices {${$DYN_CHOICES}} -help "${$RED}important info${$RST}" - #} - if {$defspace ne ""} { - set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } - #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) - if {[string first \$\{ $optionspecs] > 0} { - set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel $LVL [list ::subst $param]] - } - tcl::dict::set argdefcache_unresolved $cache_key $pt_params - } - } - #argdata_cache should be limited in some fashion or will be a big memory leak??? - if {[tcl::dict::exists $argdata_cache [list $optionspecs]]} { - #resolved cache version exists - return [tcl::dict::get $argdata_cache [list $optionspecs]] - } - } - - - - #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices - #default to 1 for convenience - - #checks with no default - #-minsize -maxsize -range - - - #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi - #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist - - #set opt_defaults [tcl::dict::create] - #set val_defaults [tcl::dict::create] - - #set opt_solos [list] - #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end - - set records [list] - set linebuild "" - - set linelist [split $optionspecs \n] - set lastindent "" - foreach ln $linelist { - if {[tcl::string::trim $ln] eq ""} {continue} - regexp {(\s*).*} $ln _all lastindent - break ;#break at first non-empty - } - #puts "indent1:[ansistring VIEW $lastindent]" - set in_record 0 - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - foreach rawline $linelist { - set recordsofar [tcl::string::cat $linebuild $rawline] - #ansi colours can stop info complete from working (contain square brackets) - #review - when exactly are ansi codes allowed/expected in record lines. - # - we might reasonably expect them in default values or choices or help strings - # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. - # - eg set line "set x \"a[a+ red]red[a]\"" - # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket - if {$has_punkansi} { - set test_complete [punk::ansi::ansistrip $recordsofar] - } else { - #review - #we only need to strip enough to stop interference with 'info complete' - set test_complete [string map [list \x1b\[ ""] $recordsofar] - } - if {![tcl::info::complete $test_complete]} { - #append linebuild [string trimleft $rawline] \n - if {$in_record} { - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. - #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. - #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. - #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) - #(note string first "" $str is fast and returns -1) - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline \n - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline \n - } else { - append linebuild $rawline \n - } - } else { - set in_record 1 - regexp {(\s*).*} $rawline _all lastindent - #puts "indent: [ansistring VIEW -lf 1 $lastindent]" - #puts "indent from rawline:$rawline " - append linebuild $rawline \n - } - } else { - set in_record 0 - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline - } else { - append linebuild $rawline - } - lappend records $linebuild - set linebuild "" - } - } - set cmd_info {} - set package_info {} - set id_info {} ;#e.g -children ?? - set doc_info {} - #set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table - set seealso_info {} - set keywords_info {} - ###set leader_min 0 - ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit - #set leader_max "" - #(common case of no leaders specified) - #set opt_any 0 - #set val_min 0 - #set val_max -1 ;#-1 for no limit - set DEF_definition_id $id - - #form_defs - set F [dict create _default [New_command_form _default]] - set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under - - #set ARGSPACE [dict create] ;#keyed on form - #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values - - set refs [dict create] - set record_type "" - set record_number -1 ;# - foreach rec $records { - set trimrec [tcl::string::trim $rec] - switch -- [tcl::string::index $trimrec 0] { - "" - # {continue} - } - incr record_number - set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict - if {[llength $record_values] % 2 != 0} { - #todo - avoid raising an error - store invalid defs keyed on id - error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" - } - # ---------------------------------------------------------- - # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. - #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! - #(form_ids_active is otherwise set in the @form handling block) - - #consider the following 2 line entry which is potentially dynamically included via a tstr: - # @form -form {* newform} - # @form -form {newform} -synopsis "cmd help ?stuff?" - #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. - #(because _default is usually 'taken over' by the first encountered form id) - #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record - #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. - - if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { - set patterns [dict get $record_values -form] - set record_form_ids [list] - foreach p $patterns { - if {[regexp {[*?\[\]]} $p]} { - #isglob - only used for matching existing forms - lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] - } else { - #don't test for existence - will define new form if necessary - lappend record_form_ids $p - } - } - #-form values could be globs that didn't match. record_form_ids could be empty.. - if {[llength $record_form_ids]} { - #only rename _default if it's the sole entry - if {[dict size $F] == 1 && [dict exists $F "_default"]} { - if {"_default" ni $record_form_ids} { - #only initial form exists - but we are mentioning new ones - #first rename the _default to first encountered new form id - #(just replace whole dict with new key - same data) - set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] - #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F - #we are only setting active because of the rename - @form is the way to change active forms list - set form_ids_active [lindex $record_form_ids 0] - } - } - foreach fid $record_form_ids { - if {![dict exists $F $fid]} { - if {$firstword eq "@form"} { - #only @form directly supplies keys - dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] - } else { - dict set F $fid [New_command_form $fid] - } - } else { - #update form with current record opts, except -form - if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } - } - } - } - } else { - #missing or empty -form - set record_form_ids $form_ids_active - if {$firstword eq "@form"} { - foreach fid $form_ids_active { - dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] - } - } - } - # ---------------------------------------------------------- - - set firstchar [tcl::string::index $firstword 0] - set secondchar [tcl::string::index $firstword 1] - if {$firstchar eq "@" && $secondchar ne "@"} { - set record_type "directive" - set directive_name $firstword - set at_specs $record_values - - switch -- [tcl::string::range $directive_name 1 end] { - dynamic { - set is_dynamic 1 - } - id { - #disallow duplicate @id line ? - #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) - - #id An id will be allocated if no id line present or the -id value is "auto" - - if {[dict exists $at_specs -id]} { - set thisid [dict get $at_specs -id] - if {$thisid ni [list $id auto]} { - error "punk::args::define @id mismatch existing: $id vs $thisid" - } - } - set id_info $at_specs - } - ref { - #a reference within the definition - #e.g see punk::args::tclcore ::after - #global reference dict - independent of forms - #ignore refs without an -id - #store all keys except -id - #complete overwrite if refid repeated later on - if {[dict exists $at_specs -id]} { - dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] - } - } - default { - #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple - #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) - #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) - #That is possibly too complicated and/or unnecessary? - #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? - - if {[dict exists $at_specs -id]} { - set copyfrom [get_spec [dict get $at_specs -id]] - #we don't copy the @id info from the source - #for now we only copy across if nothing set.. - #todo - bring across defaults for empty keys at targets? - #need to keep it simple enough to reason about behaviour easily.. - if {[dict size $copyfrom]} { - if {![dict size $cmd_info]} { - set cmd_info [dict get $copyfrom cmd_info] - } - if {![dict size $doc_info]} { - set doc_info [dict get $copyfrom doc_info] - } - - #foreach fid $record_form_ids { - # #only use elements with matching form id? - # #probably this feature mainly useful for _default anyway so that should be ok - # #cooperative doc sets specified in same file could share via known form ids too - # FORMDISPLAY has keys -header -body - # if {![dict size $F $fid $FORMDISPLAY]} { - # if {[dict exists $copyfrom FORMS $fid FORMDISPLAY]} { - # dict set F $fid FORMDISPLAY [dict get $copyfrom FORMS $fid FORMDISPLAY] - # } - # } - # #TODO - # #create leaders opts vals depending on position of @default line? - # #options on @default line to exclude/include sets??? - #} - } - } - } - form { - # arity system ? - #handle multiple parsing styles based on arities and keyword positions (and/or flags?) - #e.g see lseq manual with 3 different parsing styles. - #aim to produce a table/subtable for each - # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ - # -arities { - # 2 - # {3 anykeys {1 .. 1 to}} - # {4 anykeys {3 by}} - # {5 anykeys {1 .. 1 to 3 by}} - # }\ - # -fallback 1 - # ... - # @parser -synopsis "start 'count' count ??'by'? step?"\ - # -arities { - # {3 anykeys {1 count}} - # } - # ... - # @form -synopsis "count ?'by' step?"\ - # -arities { - # 1 - # {3 anykeys {1 by}} - # } - # - # see also after manual - # @form -arities {1} - # @form -arities { - # 1 anykeys {0 info} - # } - #todo - - #can we generate a form synopsis if -synopsis not supplied? - - #form id can be list of ints|names?, or * - if {[dict exists $at_specs -form]} { - set idlist [dict get $at_specs -form] - if {$idlist eq "*"} { - #* only applies to form ids that exist at the time - set idlist [dict keys $F] - } - set form_ids_active $idlist - } - #new form keys already created if they were needed (done for all records that have -form ) - } - package { - set package_info [dict merge $package_info $at_specs] - } - cmd { - #allow arbitrary - review - set cmd_info [dict merge $cmd_info $at_specs] - } - doc { - set doc_info [dict merge $doc_info $at_specs] - } - formdisplay { - #override the displayed argument table for the form. - #(formdisplay keys -header -body) - #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing - foreach fid $record_form_ids { - tcl::dict::set F $fid FORMDISPLAY [dict merge [tcl::dict::get $F $fid FORMDISPLAY] $at_specs] - } - } - opts { - foreach fid $record_form_ids { - if {[tcl::dict::get $F $fid argspace] eq "values"} { - error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" - } - tcl::dict::set F $fid argspace "options" - set tmp_optspec_defaults [dict get $F $fid OPTSPEC_DEFAULTS] - - foreach {k v} $at_specs { - switch -- $k { - -form { - #review - handled above - } - -any - -arbitrary - - -anyopts { - #set opt_any $v - tcl::dict::set F $fid OPT_ANY $v - } - -min { - dict set F $fid OPT_MIN $v - } - -max { - dict set F $fid OPT_MAX $v - } - -minsize - -maxsize - -range - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted { - #review - only apply to certain types? - tcl::dict::set tmp_optspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_optspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - index { - set v indexexpression - } - none - "" - - - any - ansistring - globstring - list { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_optspec_defaults -type $v - } - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -validationtransform { - #allow overriding of defaults for options that occur later - tcl::dict::set tmp_optspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -multiple - - -prefix { - #check is bool - if {![string is boolean -strict $v]} { - error "punk::args::define - Option '$k' has value '$v'of wrong type in @opts line. Must be boolean @id:$DEF_definition_id" - } - tcl::dict::set tmp_optspec_defaults $k $v - } - default { - set known { -any -anyopts -arbitrary -form -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\ - -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" - } - } - } - tcl::dict::set F $fid OPTSPEC_DEFAULTS $tmp_optspec_defaults - } ;# end foreach record_form_ids - } - leaders { - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] in [list options values]} { - error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" - } - set tmp_leaderspec_defaults [dict get $F $fid LEADERSPEC_DEFAULTS] - - foreach {k v} $at_specs { - switch -- $k { - -form { - #review - handled above - } - -min - - -minvalues { - if {$v < 0} { - error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MIN $v - #if {$leader_max == 0} { - # set leader_max -1 - #} - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MAX $v - } - -choiceprefix - - -choicerestricted { - if {![string is boolean -strict $v]} { - error "punk::args::define - invalid type of value '$v' for key '$k' in @leaders line. Must be boolean @id:$DEF_definition_id" - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -minsize - -maxsize - -range - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefixdenylist - -choiceprefixreservelist - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -choiceinfo - -choicelabels { - if {[llength $v] %2 != 0} { - error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - #-choicegroups? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_leaderspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - index { - set v indexexpression - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform { - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -multiple { - if {![string is boolean -strict $v]} { - error "punk::args::define - invalid type of value '$v' for key '$k' in @leaders line. Must be boolean @id:$DEF_definition_id" - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -unnamed { - if {![string is boolean -strict $v]} { - error "punk::args::define - invalid type of value '$v' for key '$k' in @leaders line. Must be boolean @id:$DEF_definition_id" - } - dict set F $fid LEADER_UNNAMED $v - } - -ensembleparameter { - #review - tcl::dict::set tmp_leaderspec_defaults $k $v - #error "punk::args::define - -ensembleparameter not supported as a default for @leaders - only valid on actual leader arguments" - } - default { - set known { -min -form -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\ - -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted\ - -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - -unnamed\ - } - error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid LEADERSPEC_DEFAULTS $tmp_leaderspec_defaults - - } ;#end foreach record_form_ids - - } - values { - foreach fid $record_form_ids { - dict set F $fid argspace "values" - - set tmp_valspec_defaults [dict get $F $fid VALSPEC_DEFAULTS] - - foreach {k v} $at_specs { - switch -- $k { - -form { - #review - handled above - } - -min - - -minvalues { - if {$v < 0} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" - } - #set val_min $v - dict set F $fid VAL_MIN $v - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" - } - #set val_max $v - dict set F $fid VAL_MAX $v - } - -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_valspec_defaults $k $v - } - -choiceinfo - -choicegroups { - if {[llength $v] % 2 != 0} { - error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - # -choicegroups ?? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_valspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - index { - set v indexexpression - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -multiple { - if {![string is boolean -strict $v]} { - error "punk::args::define - invalid type of value '$v' for key '$k' in @values line. Must be boolean @id:$DEF_definition_id" - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform { - tcl::dict::set tmp_valspec_defaults $k $v - } - -unnamed { - if {![string is boolean -strict $v]} { - error "punk::args::define - invalid type of value '$v' for key '$k' in @values line. Must be boolean @id:$DEF_definition_id" - } - dict set F $fid VAL_UNNAMED $v - } - default { - set known { -min -form -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\ - -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted\ - -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - -unnamed\ - } - error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid VALSPEC_DEFAULTS $tmp_valspec_defaults - } - - } - seealso { - #todo! - #like @doc, except displays in footer, multiple - sub-table? - set seealso_info [dict merge $seealso_info $at_specs] - } - keywords { - #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? - set keywords_info [dict merge $keywords_info $at_specs] - } - default { - error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @formdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" - } - } - #record_type directive - continue - } elseif {$firstchar eq "-"} { - set argname $firstword - set argdef_values $record_values - tcl::dict::set argdef_values -ARGTYPE option - - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - dict set F $fid argspace "options" - } elseif {[dict get $F $fid argspace] eq "values"} { - error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" - } - set record_type option - dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] - #lappend opt_names $argname - } - - set is_opt 1 - } else { - set argname $firstword - if {$firstchar eq "@"} { - #allow basic @@ escaping for literal argname that begins with @ - set argname [tcl::string::range $argname 1 end] - } - - set argdef_values $record_values - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - set record_type leader - tcl::dict::set argdef_values -ARGTYPE leader - #lappend leader_names $argname - set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] - if {$argname ni $temp_leadernames} { - lappend temp_leadernames $argname - tcl::dict::set F $fid LEADER_NAMES $temp_leadernames - } else { - #This can happen if the definition has repeated values - error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" - } - - if {[dict get $F $fid LEADER_MAX] >= 0} { - if {[dict get $F $fid LEADER_MAX] < [llength $temp_leadernames]} { - puts stderr "punk::args::resolve warning arg $argname LEADER_MAX == [dict get $F $fid LEADER_MAX] but [llength $temp_leadernames] leader names found @id:$DEF_definition_id" - dict set F $fid LEADER_MAX [llength $temp_leadernames] - } - } - } else { - set record_type value - tcl::dict::set argdef_values -ARGTYPE value - set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] - if {$argname ni $temp_valnames} { - lappend temp_valnames $argname - tcl::dict::set F $fid VAL_NAMES $temp_valnames - } else { - error "punk::args::define - arg $argname already present as value in '$rec' (command form:'$fid') @id:$DEF_definition_id" - } - #lappend val_names $argname - if {[dict get $F $fid VAL_MAX] >= 0} { - if {[dict get $F $fid VAL_MAX] < [llength $temp_valnames]} { - puts stderr "punk::args::resolve warning arg $argname VAL_MAX == [dict get $F $fid VAL_MAX] but [llength $temp_valnames] value names found @id:$DEF_definition_id" - dict set F $fid VAL_MAX [llength $temp_valnames] - } - } - } - } - - set is_opt 0 - } - - - #assert - we only get here if it is a value or flag specification line. - #assert argdef_values has been set to the value of record_values - - foreach fid $record_form_ids { - if {$is_opt} { - set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS] - } else { - if {[dict get $F $fid argspace] eq "values"} { - set spec_merged [dict get $F $fid VALSPEC_DEFAULTS] - } else { - set spec_merged [dict get $F $fid LEADERSPEC_DEFAULTS] - } - } - - # -> argopt argval - foreach {spec specval} $argdef_values { - #literal-key switch - bytecompiled to jumpTable - switch -- $spec { - -form { - - } - -type { - #todo - could be a list e.g {any int literal(Test)} - #case must be preserved in literal bracketed part - set typelist [list] - foreach typespec $specval { - set lc_typespec [tcl::string::tolower $typespec] - #normalize here so we don't have to test during actual args parsing in main function - switch -- $lc_typespec { - int - integer { - lappend typelist int - } - double - float { - #review - user may wish to preserve 'float' in help display - consider how best to implement - lappend typelist double - } - bool - boolean { - lappend typelist bool - } - char - character { - lappend typelist char - } - dict - dictionary { - lappend typelist dict - } - index - indexexpression { - lappend typelist indexexpression - } - "" - none { - if {$is_opt} { - #review - are we allowing clauses for flags? - #e.g {-flag -type {int int}} - #this isn't very tcl like, where we'd normally mark the flag with -multiple true and - # instead require calling as: -flag -flag - #It seems this is a reasonably rare/unlikely requirement in most commandline tools. - - if {[llength $typelist] > 1} { - #makes no sense to have 'none' in a clause - error "punk::args::define - invalid -type '$specval' for flag '$argname' ('none' in multitype) @id:$DEF_definition_id" - } - #tcl::dict::set spec_merged -type none - lappend typelist none - 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. - } - } else { - #-solo only valid for flags - error "punk::args::define - invalid -type 'none' for positional argument '$argname' (only valid for flags/options) @id:$DEF_definition_id" - } - } - any - anything { - lappend typelist any - } - ansi - ansistring { - lappend typelist ansistring - } - string - globstring { - lappend typelist $lc_typespec - } - literal { - #value is the name of the argument - if {$is_opt} { - error "punk::args::define - invalid -type 'literal' for flag argument '$argname' @id:$DEF_definition_id" - } - lappend typelist literal - } - default { - if {[string match literal* $lc_typespec]} { - set literal_tail [string range $typespec 7 end] - lappend typelist literal$literal_tail - } else { - #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW - #tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - lappend typelist $lc_typespec - } - } - } - } - tcl::dict::set spec_merged -type $typelist - } - -solo - -range - - -choices - -choicegroups - -choicemultiple - -choicecolumns - - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted - -choicelabels - -choiceinfo - - -minsize - -maxsize - -nocase - -multiple - - -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - - -regexprepass - -regexprefail - -regexprefailmsg - { - #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines - #review -solo 1 vs -type none ? conflicting values? - tcl::dict::set spec_merged $spec $specval - } - -default { - tcl::dict::set spec_merged -default $specval - if {![dict exists $argdef_values -optional]} { - tcl::dict::set spec_merged -optional 1 - } - } - -optional { - tcl::dict::set spec_merged -optional $specval - } - -ensembleparameter { - #review - only leaders? - tcl::dict::set spec_merged $spec $specval - } - -prefix { - #for flags/options - tcl::dict::set spec_merged $spec $specval - } - -validationtransform { - #string is dict only 8.7/9+ - if {[llength $specval] % 2} { - error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" - } - dict for {tk tv} $specval { - switch -- $tk { - -function - -type - -minsize - -maxsize - -range { - } - default { - set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? - error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" - } - } - } - - } - default { - if {[string match ref-* $spec]} { - #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) - #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. - if {![tcl::dict::exists $refs $specval]} { - puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" - } else { - set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" - if {$targetswitch eq "-*"} { - set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id - } else { - if {[tcl::dict::exists $refs $specval $targetswitch]} { - tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] - } else { - puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" - } - } - } - } else { - set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups\ - -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted\ - -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - -ensembleparameter\ - ] - error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" - } - } - } - } ;# end foreach {spec specval} argdef_values - - - if {$is_opt} { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - if {[tcl::dict::get $spec_merged -type] eq "none"} { - #JJJJ - dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname] - } - } else { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - tcl::dict::set F $fid ARG_INFO $argname $spec_merged - #review existence of -default overriding -optional - #if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} {} - if {![tcl::dict::get $spec_merged -optional]} { - if {$is_opt} { - set temp_opt_required [dict get $F $fid OPT_REQUIRED] - lappend temp_opt_required $argname - dict set F $fid OPT_REQUIRED $temp_opt_required - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - set temp_leader_required [dict get $F $fid LEADER_REQUIRED] - lappend temp_leader_required $argname - dict set F $fid LEADER_REQUIRED $temp_leader_required - } else { - set temp_val_required [dict get $F $fid VAL_REQUIRED] - lappend temp_val_required $argname - dict set F $fid VAL_REQUIRED $temp_val_required - } - } - } - - - if {[tcl::dict::exists $spec_merged -default]} { - if {$is_opt} { - #tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] - tcl::dict::set F $fid OPT_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } else { - #tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] - tcl::dict::set F $fid VAL_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } - } - } - } ;# end foreach fid record_form_ids - - } ;# end foreach rec $records - - - #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { - # variable id_counter - # set DEF_definition_id "autoid_[incr id_counter]" - #} - - - #now cycle through ALL forms not just form_ids_active (record_form_ids) - dict for {fid formdata} $F { - # REVIEW - #no values specified - we can allow last leader to be multiple - foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { - error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" - } - } - - #todo - disallow any -multiple == true entries if any leaders have -multiple == true? - #(creates parsing ambiguity) - #ambiguity could be resolved if at least one required option/flag eg -- - #ambiguities could theoretically also be resolved with required literals or choices - or even based on argument type - #(overcomplex? todo see if any core/tcllib commands work like that) - - #only allow a single entry within VAL_NAMES to have -multiple == true - #example of command with non-trailing -multiple == true is core command: 'file copy ?-force? ?--? source ?source?... targetDir - set val_multiples 0 - foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { - if {$val_multiples > 0} { - error "bad setting -multiple true on argument spec for value '$valname' in command form:'$fid'. Only a single value argument specification can be marked with -multiple true @id:$DEF_definition_id" - } - incr val_multiples - } - } - - #todo - document that ambiguities in API are likely if both @leaders and @values used - #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) - - - dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata LEADERSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata OPTSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata VALSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - - - - - #todo - precalculate a set of 'arity' entries for each form - #We want a structure for the arg parser to get easy access and make a fast decision on which form applies - #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? - #1) after ms (1 1) - #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? - #3) after cancel id (2 2) - #4) after cancel script ?script...? (2 -1) - #5) after idle script ?script...? (1 -1) - #6) after info ?id? (1 2) - - #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) - - #in the above case we have no unique total_arity - #we would also want to consider values when selecting - #e.g given the invalid command "after cancel" - # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. - - - - set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands - #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use - #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form - #e.g commandline completion could show list of synopsis entries to select from - - set form_info [dict create] - dict for {fid fdict} $F { - dict set form_info $fid {} - dict for {optk optv} $fdict { - if {[string match -* $optk]} { - dict set form_info $fid $optk $optv - } - } - } - - set argdata_dict [tcl::dict::create\ - id $DEF_definition_id\ - cmd_info $cmd_info\ - doc_info $doc_info\ - package_info $package_info\ - seealso_info $seealso_info\ - id_info $id_info\ - FORMS $F\ - form_names [dict keys $F]\ - form_info $form_info\ - ] - - tcl::dict::set argdata_cache $cache_key $argdata_dict - if {$is_dynamic} { - #also cache resolved version - tcl::dict::set argdata_cache [list $optionspecs] $argdata_dict - } - - #tcl::dict::set id_cache_rawdef $DEF_definition_id $args - #puts "xxx:$result" - return $argdata_dict - } - - #return raw definition list as created with 'define' - # - possibly with unresolved dynamic parts - proc raw_def {id} { - variable id_cache_rawdef - set realid [real_id $id] - if {![dict exists $id_cache_rawdef $realid]} { - return "" - } - return [tcl::dict::get $id_cache_rawdef $realid] - } - - - namespace eval argdoc { - variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @formdisplay @seealso @leaders @opts @values leaders opts values} - variable resolved_def_TYPE_CHOICEGROUPS { - directives {@id @package @cmd @ref @doc @formdisplay @seealso} - argumenttypes {leaders opts values} - remaining_defaults {@leaders @opts @values} - } - - lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { - @id -id ::punk::args::resolved_def - @cmd -name punk::args::resolved_def -help\ - "Resolves or retrieves the previously resolved definition and - uses the 'spec' form to build a response in definition format. - - Pulling argument definition data from another function is a form - of tight coupling to the other function that should be done with - care. - - Note that the directives @leaders @opts @values may appear multiple - times in a source definition - applying defaults for arguments that - follow. When retrieving these - there is only a single result for - each that represents the defaults after all have been applied. - When retrieving -types * each of these will be positioned before - the arguments of that type - but this doesn't mean there was a single - leading directive for this argument type in the source definition. - Each argument has already had its complete specification recorded in - its own result. - - When manually specifying -types, the order @leaders then @opts then - @values must be maintained - but if they are placed before their - corresponding arguments, they will not affect the retrieved arguments - as these arguments are already fully spec'd. The defaults from the - source can be removed by adding @leaders, @opts @values to the - -antiglobs list, but again - this won't affect the existing arguments. - Each argument can have members of its spec overridden using the - -override dictionary. - " - @leaders -min 0 -max 0 - @opts - -return -default text -choices {text dict} - -form -default 0 -help\ - "Ordinal index or name of command form" - - #no restriction on number of types/repetitions? - -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} - -antiglobs -default {} -type list -help\ - "Glob patterns for directive or argument/flags to - be suppressed" - -override -type dict -optional 1 -default "" -help\ - "dict of dicts. Key in outer dict is the name of a - directive or an argument. Inner dict is a map of - overrides/additions (- ...) for that line. - " - @values -min 1 -max -1 - id -type string -help\ - "identifer for a punk::args definition - This will usually be a fully-qualifed - path for a command name" - pattern -type string -optional 1 -default * -multiple 1 -help\ - "glob-style patterns for retrieving value or switch - definitions. - - If -type is * and pattern is * the entire definition including - directive lines will be returned in line form. - (directives are lines beginning with - @ e.g @id, @cmd etc) - - if -type is leaders,opts or values matches from that type - will be returned. - - if -type is another directive such as @id, @doc etc the - patterns are ignored. - - " - }]] - } - - - proc resolved_def {args} { - #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. - set opts [dict create\ - -return text\ - -types {}\ - -form 0\ - -antiglobs {}\ - -override {}\ - ] - if {[llength $args] < 1} { - #must have at least id - punk::args::parse $args withid ::punk::args::resolved_def - return - } - set patterns [list] - - #a definition id must not begin with "-" ??? review - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {$a in {-type -types}} { - incr i - dict set opts -types [lindex $args $i] - } elseif {[string match -* $a]} { - incr i - dict set opts $a [lindex $args $i] - } else { - set id [lindex $args $i] - set patterns [lrange $args $i+1 end] - break - } - if {$i == [llength $args]-1} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - if {![llength $patterns]} { - set patterns [list *] - } - dict for {k v} $opts { - #set fullk [tcl::prefix::match -error "" {-return -form -types -antiglobs -override} $k] - switch -- $k { - -return - -form - -types - -antiglobs - -override {} - default { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - } - set typelist [dict get $opts -types] - if {[llength $typelist] == 0} { - set typelist {*} - } - foreach type $typelist { - if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - - - variable id_cache_rawdef - set realid [real_id $id] - if {$realid eq ""} { - return - } - - set deflist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] - - set opt_form [dict get $opts -form] - if {[string is integer -strict $opt_form]} { - set formname [lindex [dict get $specdict form_names] $opt_form] - } else { - set formname $opt_form - } - set opt_override [dict get $opts -override] - set opt_return [dict get $opts -return] - - #set arg_info [dict get $specdict ARG_INFO] - set arg_info [dict get $specdict FORMS $formname ARG_INFO] - set argtypes [dict create leaders leader opts option values value] - - set opt_antiglobs [dict get $opts -antiglobs] - set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] - set suppressed_directives [list] - set suppressed_args [list] - foreach ag $opt_antiglobs { - foreach d $directives { - if {[string match $ag $d]} { - lappend suppressed_directives $d - } - } - foreach argname [dict keys $arg_info] { - if {[string match $ag $argname]} { - lappend suppressed_args $argname - } - } - } - set suppressed_directives [lsort -unique $suppressed_directives] - set suppressed_args [lsort -unique $suppressed_args] - - set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] - - set globbed [list] - foreach pat $patterns { - set matches [dict keys $arg_info $pat] - lappend globbed {*}$matches - } - set globbed [lsort -unique $globbed] - #maintain order of original arg_info keys in globbed results - set ordered_globbed [list] - foreach a [dict keys $arg_info] { - if {$a ni $ordered_globbed && $a in $globbed} { - lappend ordered_globbed $a - } - } - set included_args [punk::args::system::punklib_ldiff $ordered_globbed $suppressed_args] - - set result "" - set resultdict [dict create] - foreach type $typelist { - switch -exact -- $type { - * { - if {"@id" in $included_directives} { - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - foreach directive {@package @cmd @doc @seealso} { - set dshort [string range $directive 1 end] - if {"$directive" in $included_directives} { - if {[dict exists $opt_override $directive]} { - append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict ${dshort}_info]" - dict set resultdict $directive [dict get $specdict ${dshort}_info] - } - } - } - - #todo @formdisplay - - - #output ordered by leader, option, value - foreach pseudodirective {leaders opts values} tp {leader option value} { - set directive "@$pseudodirective" - switch -- $directive { - @leaders {set defaults_key LEADERSPEC_DEFAULTS} - @opts {set defaults_key OPTSPEC_DEFAULTS} - @values {set defaults_key VALSPEC_DEFAULTS} - } - - if {"$directive" in $included_directives} { - if {[dict exists $opt_override "$directive"]} { - append result \n "$directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict FORMS $formname $defaults_key]" - dict set resultdict $directive [dict get $specdict FORMS $formname $defaults_key] - } - } - - if {$pseudodirective in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq $tp} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "\"$m\" [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "\"$m\" $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - - } - @id { - if {"@id" in $included_directives} { - #only a single id record can exist - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - } - @package - @cmd - @doc - @seealso { - if {"$type" in $included_directives} { - set tp [string range $type 1 end] ;# @package -> package - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict ${tp}_info]" - dict set resultdict $type [dict get $specdict ${tp}_info] - } - } - #todo @formdisplay - } - @leaders - @opts - @values { - #these are the active defaults for further arguments - if {"$type" in $included_directives} { - switch -- $type { - @leaders {set defaults_key LEADERSPEC_DEFAULTS} - @opts {set defaults_key OPTSPEC_DEFAULTS} - @values {set defaults_key VALSPEC_DEFAULTS} - } - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS]" - dict set resultdict $type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] - } - } - } - leaders - opts - values { - #pseudo-directives - if {$type in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "\"$m\" [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "\"$m\" $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - default { - } - } - if {$opt_return eq "text"} { - return $result - } else { - return $resultdict - } - } - } - - proc resolved_def_values {id {patternlist *}} { - variable id_cache_rawdef - set realid [real_id $id] - if {$realid ne ""} { - set deflist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [resolve {*}$deflist] - set arg_info [dict get $specdict ARG_INFO] - set valnames [dict get $specdict VAL_NAMES] - set result "" - if {$patternlist eq "*"} { - foreach v $valnames { - set def [dict get $arg_info $v] - set def [dict remove $def -ARGTYPE] - append result \n "$v $def" - } - return $result - } else { - foreach pat $patternlist { - set matches [dict keys $arg_info $pat] - set matches [lsearch -all -inline -glob $valnames $pat] - foreach m $matches { - set def [dict get $arg_info $m] - set def [dict remove $def -ARGTYPE] - append result \n "$m $def" - } - } - return $result - } - } - } - #proc resolved_def_leaders ?? - #proc resolved_def_opts ?? - - proc get_spec {id} { - set deflist [raw_def $id] - if {$deflist eq ""} { - return - } - return [resolve {*}$deflist] - #if {[id_exists $id]} { - # return [resolve {*}[raw_def $id]] - #} - } - proc is_dynamic {id} { - variable id_cache_rawdef - variable rawdef_cache - set deflist [raw_def $id] - if {[dict exists $rawdef_cache $deflist -dynamic]} { - return [dict get $rawdef_cache $deflist -dynamic] - } - return [rawdef_is_dynamic $deflist] - #@dynamic only has meaning as 1st element of a def in the deflist - } - - #@id must be within first 4 lines of a block - or assign auto - #review - @dynamic block where -id not explicitly set? - disallow? - proc rawdef_id {rawdef} { - set id "" - foreach d $rawdef { - foreach ln [lrange [split $d \n] 0 4] { - if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { - if {$firstword eq "@id"} { - if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { - set id [dict get $rest -id] - break - } - } - } - } - if {$id ne ""} { - break - } - } - if {$id eq "" || [string tolower $id] eq "auto"} { - variable id_counter - set id "autoid_[incr id_counter]" - } - #puts "==>id: $id" - return $id - } - #test the rawdef for @dynamic directive - proc rawdef_is_dynamic {rawdef} { - #temporary - old way - set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] - if {$flagged_dynamic} { - return true - } - foreach d $rawdef { - if {[regexp {\s*(\S+)} $d _match firstword]} { - if {$firstword eq "@dynamic"} { - return true - } - } - } - return false - } - - variable aliases - set aliases [dict create] - - lappend PUNKARGS [list { - @id -id ::punk::args::get_ids - @cmd -name punk::args::get_ids -help\ - "return list of ids for argument definitions" - @values -min 0 -max 1 - match -default * -help\ - "exact id or glob pattern for ids" - }] - proc get_ids {{match *}} { - variable id_cache_rawdef - variable aliases - return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] - } - - #we don't automatically test for (autodef)$id - only direct ids and aliases - proc id_exists {id} { - variable aliases - if {[tcl::dict::exists $aliases $id]} { - return 1 - } - variable id_cache_rawdef - tcl::dict::exists $id_cache_rawdef $id - } - proc set_alias {alias id} { - variable aliases - dict set aliases $alias $id - } - proc unset_alias {alias} { - variable aliases - dict unset aliases $alias - } - proc get_alias {alias} { - variable aliases - if {[dict exists $aliases $alias]} { - return [tcl::dict::get $aliases $alias] - } - } - - proc real_id {id} { - variable id_cache_rawdef - variable aliases - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } else { - set check_updates [list [namespace qualifiers $id]] - #puts stderr "---->real_id '$id' update_definitions $check_updates" - if {![llength [update_definitions $check_updates]]} { - #nothing new loaded - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } else { - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } - } - } - - proc status {} { - upvar ::punk::args::register::NAMESPACES registered - upvar ::punk::args::register::loaded_packages loaded_packages - upvar ::punk::args::register::loaded_info loaded_info - upvar ::punk::args::register::scanned_packages scanned_packages - upvar ::punk::args::register::scanned_info scanned_info - set result "" - # [format %-${w0}s $idtail] - set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] - append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n - set width_c2 [string length "Scanned_ids"] - set width_c3 [string length "Scantime_us"] - set width_c4 [string length "Loaded_defs"] - set width_c5 [string length "Loadtime_us"] - set count_unloaded 0 - set count_loaded 0 - foreach ns $registered { - if {$ns in $scanned_packages} { - set ids [dict get $scanned_info $ns idcount] - set scan_us [dict get $scanned_info $ns time] - } else { - set ids "" - set scan_us "" - } - if {$ns in $loaded_packages} { - incr count_loaded - set ldefs [dict get $loaded_info $ns defcount] - set load_us [dict get $loaded_info $ns time] - } else { - incr count_unloaded - set ldefs "" - set load_us "" - } - append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n - } - append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" - return $result - } - - #scanned_packages (list) - #namespace_docpackages (dict) - proc update_definitions {{nslist *}} { - #puts "----> update_definitions '$nslist'" - if {[set gposn [lsearch $nslist {}]] >= 0} { - lset nslist $gposn :: - } - upvar ::punk::args::register::NAMESPACES registered ;#list - upvar ::punk::args::register::loaded_packages loaded_packages ;#list - upvar ::punk::args::register::loaded_info loaded_info ;#dict - upvar ::punk::args::register::scanned_packages scanned_packages ;#list - upvar ::punk::args::register::scanned_info scanned_info ;#dict - upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict - - - #puts stderr "-->update_definitions '$nslist'" - #needs to run quickly - especially when no package namespaces to be scanned for argdefs - #e.g - gets called for each subcommand of an ensemble (could be many) - # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. - #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. - # -- --- --- --- --- --- - # common-case fast-path - - if {[llength $loaded_packages] == [llength $registered]} { - #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. - #assert - if all are registered - then all have been scanned - return {} - } - # -- --- --- --- --- --- - - set unscanned [punklib_ldiff $registered $scanned_packages] - if {[llength $unscanned]} { - foreach pkgns $unscanned { - set idcount 0 - set ts_start [clock microseconds] - if {[info exists ${pkgns}::PUNKARGS]} { - set seen_documentedns [list] ;#seen per pkgns - foreach definitionlist [set ${pkgns}::PUNKARGS] { - #namespace eval $evalns [list punk::args::define {*}$definitionlist] - set id [rawdef_id $definitionlist] - if {[string match autoid_* $id]} { - puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" - puts stderr "definition:\n" - foreach d $definitionlist { - set out "" - foreach ln [split $d \n] { - append out " " $ln \n - } - puts $out - } - continue - } - #todo - detect duplicate ids (last will silently win.. should be reported somewhere) - incr idcount - set documentedns [namespace qualifiers $id] - if {$documentedns eq ""} {set documentedns ::} - if {$documentedns ni $seen_documentedns} { - #don't add own ns as a key in namespace_docpackages - if {$documentedns ne $pkgns} { - dict lappend namespace_docpackages $documentedns $pkgns - } - lappend seen_documentedns $documentedns - } - } - } - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - dict set scanned_info $pkgns [dict create time $diff idcount $idcount] - #we count it as scanned even if PUNKARGS didn't exist - #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) - lappend scanned_packages $pkgns - } - } - - - - if {"*" in $nslist} { - set needed [punklib_ldiff $registered $loaded_packages] - } else { - set needed [list] - foreach pkgns $nslist { - if {![string match ::* $pkgns]} { - puts stderr "warning: update_definitions received unqualified ns: $pkgns" - set pkgns ::$pkgns - } - if {$pkgns in $registered && $pkgns ni $loaded_packages} { - lappend needed $pkgns - } - #argdoc sub namespace is a standard place to put defs that match the namespace below - #(generally the PUNKARGS in a namespace should apply to own ns) - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { - lappend needed $docns - } - } - if {[dict exists $namespace_docpackages $pkgns]} { - #this namespace has other argdef sources - foreach docns [dict get $namespace_docpackages $pkgns] { - if {$docns ni $loaded_packages} { - lappend needed $docns - } - } - } - } - } - - - - set newloaded [list] - foreach pkgns $needed { - #puts stderr "update_definitions Loading: $pkgns" - set ts_start [clock microseconds] - set def_count 0 - if {![catch { - if {[info exists ${pkgns}::PUNKARGS]} { - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - namespace eval ${pkgns}::argdoc { - set epath [namespace path] - set pkgns [namespace parent] - if {$pkgns ni $epath} { - namespace path [list {*}$epath $pkgns] ;#add to tail - } - - } - set evalns $docns - } else { - set evalns $pkgns - } - foreach definitionlist [set ${pkgns}::PUNKARGS] { - namespace eval $evalns [list punk::args::define {*}$definitionlist] - incr def_count - } - } - - #process list of 2-element lists - if {[info exists ${pkgns}::PUNKARGS_aliases]} { - foreach adef [set ${pkgns}::PUNKARGS_aliases] { - punk::args::set_alias {*}$adef - } - } - } errMsg]} { - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - lappend loaded_packages $pkgns - lappend newloaded $pkgns - dict set loaded_info $pkgns [dict create time $diff defcount $def_count] - } else { - puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" - } - } - return $newloaded - } - - #for use within get_dict only - #This mechanism gets less-than-useful results for oo methods - #e.g {$obj} - proc Get_caller {} { - #set call_level -3 ;#for get_dict call - set call_level -4 - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - #puts "-->$cmdinfo" - #puts "-->[tcl::info::frame -3]" - while {[string last \n $cmdinfo] >= 1} { - #looks like a script - haven't gone up far enough? - #(e.g patternpunk oo system: >punk . poses -invalidoption) - incr call_level -1 - if {[catch { - set nextup [tcl::info::frame $call_level] - } ]} { - break - } - set cmdinfo [tcl::dict::get $nextup cmd] - set caller [regexp -inline {\S+} $cmdinfo] - if {[interp alias {} $caller] ne ""} { - #puts "found alias for caller $caller to [interp alias {} $caller]" - #see if we can go further - incr call_level -1 - if {[catch { - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - } errM ]} { - puts "err: $errM" - break - } - } - } - set caller [regexp -inline {\S+} $cmdinfo] - if {$caller eq "namespace"} { - # review - message? - set cmdinfo "Get_caller (punk::args::get_dict?) called from namespace" - } - return $cmdinfo - } - - - # -------------------------------------- - #test of Get_caller - lappend PUNKARGS [list { - @id -id ::punk::args::test1 - @values -min 0 -max 0 - }] - proc test_get_dict {args} { - punk::args::get_dict [punk::args::raw_def ::punk::args::test1] $args - } - proc test_get_by_id {args} { - punk::args::get_by_id ::punk::args::test1 $args - } - #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. - proc test_callers {args} { - if {![llength $args]} { - puts "these test functions accept no arguments" - puts "Call with arg(s) to compare error output" - } - - if {[catch {test_get_dict {*}$args} errM]} { - puts $errM - } - puts "------------" - if {[catch {test_get_by_id {*}$args} errM]} { - puts $errM - } - return done - } - # -------------------------------------- - - set map "" - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::arg_error - @cmd -name punk::args::arg_error -help\ - "Generates a table (by default) of usage information for a command. - A trie system is used to create highlighted prefixes for command - switches and for subcommands or argument/switch values that accept - a defined set of choices. These prefixes match the mechanism used - to validate arguments (based on tcl::prefix::match). - - This function is called during the argument parsing process - (if the definition is not only being used for documentation) - It is also called by punk::args::usage which is in turn - called by the punk::ns introspection facilities which creates - on the fly definitions for some commands such as ensembles and - oo objects where a manually defined one isn't present. - " - @leaders -min 2 -max 2 - msg -type string -help\ - "Error message to display immediately prior to usage table. - May be empty string to just display usage. - " - spec_dict -type dict -help\ - "Dictionary of argument specifications. - This is the internal format parsed from - the textual definition. It contains the data - organised/optimised to allow the final arg - parser/validator to make decisions. - " - @opts - -badarg -type string -help\ - "name of an argument to highlight" - -parsedargs -type dict -help\ - "Result of successful punk::pargs::parse - (currently only looks at 'received')" - -aserror -type boolean -help\ - "If true, the usage table is raised as an error message, - otherwise it is returned as a value." - -return -choices {string table tableobject} -choicelabels { - string "no table layout" - tableobject "table object cmd" - table "full table layout" - } - -scheme -default error -choices {nocolour info error} - -form -default 0 -help\ - "Ordinal index or name of command form" - }] ] - - if {[catch {package require punk::ansi}]} { - proc punk::args::a {args} {} - proc punk::args::a+ {args} {} - } else { - namespace eval ::punk::args { - namespace import ::punk::ansi::a ::punk::ansi::a+ - } - } - variable arg_error_CLR - array set arg_error_CLR {} - set arg_error_CLR(errormsg) [a+ brightred] - set arg_error_CLR(title) "" - set arg_error_CLR(check) [a+ brightgreen] - set arg_error_CLR(solo) [a+ brightcyan] - set arg_error_CLR(choiceprefix) [a+ underline] - set arg_error_CLR(badarg) [a+ brightred] - set arg_error_CLR(goodarg) [a+ green strike] - set arg_error_CLR(goodchoice) [a+ reverse] - set arg_error_CLR(linebase_header) [a+ white] - set arg_error_CLR(cmdname) [a+ brightwhite] - set arg_error_CLR(groupname) [a+ bold] - set arg_error_CLR(ansiborder) [a+ bold] - set arg_error_CLR(ansibase_header) [a+ bold] - set arg_error_CLR(ansibase_body) [a+ white] - variable arg_error_CLR_nocolour - array set arg_error_CLR_nocolour {} - set arg_error_CLR_nocolour(errormsg) [a+ bold] - set arg_error_CLR_nocolour(title) [a+ bold] - set arg_error_CLR_nocolour(check) "" - set arg_error_CLR_nocolour(solo) "" - set arg_error_CLR_nocolour(badarg) [a+ reverse] ;#? experiment - set arg_error_CLR_nocolour(goodarg) [a+ strike] - set arg_error_CLR_nocolour(cmdname) [a+ bold] - set arg_error_CLR_nocolour(linebase_header) "" - set arg_error_CLR_nocolour(linebase) "" - set arg_error_CLR_nocolour(ansibase_body) "" - variable arg_error_CLR_info - array set arg_error_CLR_info {} - set arg_error_CLR_info(errormsg) [a+ brightred bold] - set arg_error_CLR_info(title) [a+ brightyellow bold] - set arg_error_CLR_info(check) [a+ brightgreen bold] - set arg_error_CLR_info(choiceprefix) [a+ brightgreen bold] - set arg_error_CLR_info(groupname) [a+ cyan bold] - set arg_error_CLR_info(ansiborder) [a+ brightcyan bold] - set arg_error_CLR_info(ansibase_header) [a+ cyan] - set arg_error_CLR_info(ansibase_body) [a+ white] - variable arg_error_CLR_error - array set arg_error_CLR_error {} - set arg_error_CLR_error(errormsg) [a+ brightred bold] - set arg_error_CLR_error(title) [a+ brightcyan bold] - set arg_error_CLR_error(check) [a+ brightgreen bold] - set arg_error_CLR_error(choiceprefix) [a+ brightgreen bold] - set arg_error_CLR_error(groupname) [a+ cyan bold] - set arg_error_CLR_error(ansiborder) [a+ brightyellow bold] - set arg_error_CLR_error(ansibase_header) [a+ yellow] - set arg_error_CLR_error(ansibase_body) [a+ white] - - - #bas ic recursion blocker - variable arg_error_isrunning 0 - proc arg_error {msg spec_dict args} { - #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. - #accept an option here so that we can still use full output for usage requests. - #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args - #Development/experimentation may be done with full table-based error reporting - but for production release it - #may be desirable to reduce overhead on catches. - #consider per-namespace or namespace-tree configurability. - #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due - #to resource availability etc - so the slower error generation time may not always be a problem. - #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling - #code which has no use for the enhanced error info. - #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. - #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system - #todo - #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error - #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) - - #todo - document unnamed leaders and unnamed values where -min and/or -max specified - #e.g punk::args::parse {} withdef {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} - #only |?-x?|string|... is shown in the output table. - #should be something like: - # |arg | - # |?-x? | - # |arg | - # |?arg...?| - # Where/how to specify counts? - #also.. - # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? - # - - - #limit colours to standard 16 so that themes can apply to help output - variable arg_error_isrunning - if {$arg_error_isrunning} { - error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" - } - - if {[llength $args] %2 != 0} { - error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" - } - - set arg_error_isrunning 1 - - set badarg "" - set parsedargs [dict create] ;#dict with keys: leaders,opts,values,received,solos,multis (as from punk::args::parse) - set goodargs [list] - set returntype table ;#table as string - set as_error 1 ;#usual case is to raise an error - set scheme error - set form 0 - dict for {k v} $args { - set fullk [tcl::prefix::match -error "" {-badarg -parsedargs -aserror -return -scheme -form} $k] - switch -- $fullk { - -badarg { - set badarg $v - } - -parsedargs { - #todo? - dict for {set setinfo} $v { - switch -- $set { - received { - foreach {r rpos} $setinfo { - if {$r ni $goodargs} { - lappend goodargs $r - } - } - } - } - } - set parsedargs $v - } - -aserror { - if {![string is boolean -strict $v]} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" - } - set as_error $v - } - -scheme { - set scheme $v - } - -return { - if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" - } - set returntype $v - } - -form { - set form $v - } - default { - set arg_error_isrunning 0 - error "arg_error invalid option $k. Known_options: -badarg -parsedargs -aserror -scheme -return -form" - } - } - } - #todo - scheme - use config and iterm toml definitions etc - switch -- $scheme { - "" - -nocolor - -nocolour { - set scheme nocolour - } - info - error {} - default { - set scheme na - } - } - set formnames [dict get $spec_dict form_names] - if {[string is integer -strict $form]} { - if {$form < 0 || $form > [llength $formnames]-1} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" - } - set selected_forms [list [lindex $formnames $form]] - } else { - if {$form eq "*"} { - set selected_forms $formnames - } else { - if {$form in $formnames} { - set selected_forms [list $form] - } else { - set arg_error_isrunning 0 - error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" - } - } - } - - - #hack some basics for now. - #for coloured schemes - use bold as well as brightcolour in case colour off. - upvar ::punk::args::arg_error_CLR CLR - - switch -- $scheme { - nocolour { - variable arg_error_CLR_nocolour - array set CLR [array get arg_error_CLR_nocolour - } - info { - variable arg_error_CLR_info - array set CLR [array get arg_error_CLR_info] - } - error { - variable arg_error_CLR_error - array set CLR [array get arg_error_CLR_error] - } - na { - } - } - - - #set RST [a] - set RST "\x1b\[m" - set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. - - #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error - #e.g list_as_table - - # use basic colours here to support terminals without extended colours - #todo - add checks column (e.g -minsize -maxsize) - set errmsg $msg - if {![catch {package require textblock}]} { - set has_textblock 1 - } else { - set has_textblock 0 - #couldn't load textblock package - #just return the original errmsg without formatting - } - set use_table 0 - if {$has_textblock && $returntype in {table tableobject}} { - set use_table 1 - } - set errlines [list] ;#for non-textblock output - if {[catch { - if {$use_table} { - append errmsg \n - } else { - if {($returntype in {table tableobject}) && !$has_textblock} { - append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n - } else { - append errmsg \n - } - } - set cmdname [Dict_getdef $spec_dict cmd_info -name ""] - set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] - - set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] - set docurl [Dict_getdef $spec_dict doc_info -url ""] - - #set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] - #set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] - #if {"$argdisplay_header$argdisplay_body" eq ""} { - # set is_custom_argdisplay 0 - #} else { - # set is_custom_argdisplay 1 - #} - - #temp - TODO - set argdisplay_header "" - set argdisplay_body "" - set is_custom_argdisplay 0 - - - set blank_header_col [list] - if {$cmdname ne ""} { - lappend blank_header_col "" - set cmdname_display $CLR(cmdname)$cmdname$RST - } else { - set cmdname_display "" - } - if {$cmdhelp ne ""} { - lappend blank_header_col "" - #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] - set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] - } else { - set cmdhelp_display "" - } - if {$docurl ne ""} { - lappend blank_header_col "" - set docurl_display [a+ white]$docurl$RST - } else { - set docurl_display "" - } - #synopsis - set synopsis "" - set form_info [dict get $spec_dict form_info] - dict for {fid finfo} $form_info { - set form_synopsis [Dict_getdef $finfo -synopsis ""] - if {$form_synopsis eq ""} { - #todo - set form_synopsis [punk::args::synopsis -form $fid [dict get $spec_dict id]] - if {[string length $form_synopsis] > 90} { - set form_synopsis [punk::args::synopsis -return summary -form $fid [dict get $spec_dict id]] - } - if {[string match (autodef)* $form_synopsis]} { - set form_synopsis [string range $form_synopsis 9 end] - } - } - if {$fid in $selected_forms} { - set form_synopsis [punk::ansi::a+ underline]$form_synopsis[punk::ansi::a+ nounderline] - } - append synopsis $form_synopsis \n - } - if {$synopsis ne ""} { - set synopsis [string trimright $synopsis \n] - lappend blank_header_col "" - } - - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - if {$use_table} { - set t [textblock::class::table new "$CLR(title)Usage$RST"] - $t add_column -headers $blank_header_col -minwidth 3 - $t add_column -headers $blank_header_col - - if {!$is_custom_argdisplay} { - lappend blank_header_col "" - #spanned columns in default argdisplay area - $t add_column -headers $blank_header_col ;#Default - $t add_column -headers $blank_header_col ;#Multi - $t add_column -headers $blank_header_col ;#Help - set arg_colspans {1 4 0 0 0} - } else { - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - set arg_colspans {1 1} - } - } - set h 0 - if {$cmdname ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] - } else { - lappend errlines "COMMAND: $cmdname_display" - } - incr h - } - if {$cmdhelp ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] - } else { - lappend errlines "Description: $cmdhelp_display" - } - incr h - } - if {$docurl ne ""} { - if {![catch {package require punk::ansi}]} { - set docurl [punk::ansi::hyperlink $docurl] - } - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] - } else { - lappend errlines "$docname $docurl_display" - } - incr h - } - if {$synopsis ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Synopsis: [punk::ansi::ansiwrap brightwhite $synopsis]] - } else { - #todo - lappend errlines "Synopsis:\n$synopsis" - } - incr h - } - - - if {$use_table} { - if {$is_custom_argdisplay} { - if {$argdisplay_header ne ""} { - $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] - } - } else { - $t configure_header $h -values {Arg Type Default Multi Help} - } - } else { - lappend errlines " --ARGUMENTS-- " - } - - if {$is_custom_argdisplay} { - if {$use_table} { - #using overall container table - #header already added - #TODO - review textblock::table features - #we can't currently span columns within the table body. - #This feature could allow hidden data columns (and sort on hidden col?) - #potentially require coordination with header colspans? - $t add_row [list "" $argdisplay_body] - } else { - if {$argdisplay_header ne ""} { - lappend errlines $argdisplay_header - } - lappend errlines {*}$argdisplay_body - } - } else { - - #set A_DEFAULT [a+ brightwhite Brightgreen] - set A_DEFAULT "" - set A_BADARG $CLR(badarg) - set A_GOODARG $CLR(goodarg) - set A_GOODCHOICE $CLR(goodchoice) - set greencheck $CLR(check)\u2713$RST ;#green tick - set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply - if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { - #A_PREFIX can resolve to empty string if colour off - #we then want to display underline instead - set A_PREFIX [a+ underline] - set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space - } else { - set A_PREFIXEND $RST - } - - #TODO - foreach fid - set fid [lindex $selected_forms 0] - set form_dict [dict get $spec_dict FORMS $fid] - - set opt_names [list] - set opt_names_display [list] - set lookup_optset [dict create] - if {[llength [dict get $form_dict OPT_NAMES]]} { - set all_opts [list] - foreach optset [dict get $form_dict OPT_NAMES] { - set optmembers [split $optset |] - lappend all_opts {*}$optmembers - foreach o $optmembers { - dict set lookup_optset $o $optset - #goodargs - } - } - set full_goodargs [list] - #goodargs may have simplified entries for received opts of form -alias1|-alias2|-realname - #map -realname to full argname - foreach g $goodargs { - if {[string match -* $g] && [dict exists $lookup_optset $g]} { - lappend full_goodargs [dict get $lookup_optset $g] - } else { - lappend full_goodargs $g - } - } - set goodargs $full_goodargs - if {![catch {package require punk::trie}]} { - #todo - reservelist for future options - or just to affect the prefix calculation - # (similar to -choiceprefixreservelist) - - set trie [punk::trie::trieclass new {*}$all_opts --] - set idents [dict get [$trie shortest_idents ""] scanned] - #todo - check opt_prefixdeny - - $trie destroy - foreach optset [dict get $form_dict OPT_NAMES] { - set arginfo [dict get $form_dict ARG_INFO $optset] - if {[dict get $arginfo -prefix]} { - set opt_members [split $optset |] - set odisplay [list] - foreach opt $opt_members { - set id [dict get $idents $opt] - #REVIEW - if {$id eq $opt} { - set prefix $opt - set tail "" - } else { - set idlen [string length $id] - set prefix [string range $opt 0 $idlen-1] - set tail [string range $opt $idlen end] - } - lappend odisplay $A_PREFIX$prefix$A_PREFIXEND$tail - } - #lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail - lappend opt_names_display [join $odisplay |] - } else { - lappend opt_names_display $optset - } - #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] - lappend opt_names $optset - } - } else { - set opt_names [dict get $form_dict OPT_NAMES] - set opt_names_display $opt_names - } - } - set leading_val_names [dict get $form_dict LEADER_NAMES] - set trailing_val_names [dict get $form_dict VAL_NAMES] - - #dict for {argname info} [tcl::dict::get $form_dict arg_info] { - # if {![string match -* $argname]} { - # lappend leading_val_names [lpop trailing_val_names 0] - # } else { - # break - # } - #} - #if {![llength $leading_val_names] && ![llength $opt_names]} { - # #all vals were actually trailing - no opts - # set trailing_val_names $leading_val_names - # set leading_val_names {} - #} - set leading_val_names_display $leading_val_names - set trailing_val_names_display $trailing_val_names - #puts "--> parsedargs: $parsedargs" - set parsed_leaders [Dict_getdef $parsedargs leaders {}] - set parsed_opts [Dict_getdef $parsedargs opts {}] - set parsed_values [Dict_getdef $parsedargs values {}] - - #display options first then values - foreach argumentclassinfo [list [list leaders $leading_val_names_display $leading_val_names $parsed_leaders] [list opts $opt_names_display $opt_names $parsed_opts] [list values $trailing_val_names_display $trailing_val_names $parsed_values]] { - lassign $argumentclassinfo argumentclass argnames_display argnames parsedvalues - - foreach argshow $argnames_display arg $argnames { - set arginfo [dict get $form_dict ARG_INFO $arg] - if {[dict exists $arginfo -default]} { - set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" - } else { - set default "" - } - set help [Dict_getdef $arginfo -help ""] - set allchoices_originalcase [list] - set choices [Dict_getdef $arginfo -choices {}] - set choicegroups [Dict_getdef $arginfo -choicegroups {}] - set choicemultiple [dict get $arginfo -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] - set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] - set choiceprefixreservelist [Dict_getdef $arginfo -choiceprefixreservelist {}] ;#names used to calc prefix - but not available as actual choice. - if {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - set is_multiple 1 - } else { - set multiple "" - set is_multiple 0 - } - if {[dict exists $choicegroups ""]} { - dict lappend choicegroups "" {*}$choices - } else { - set choicegroups [dict merge [dict create "" $choices] $choicegroups] - } - #review - does choiceprefixdenylist need to be added? - dict for {groupname clist} $choicegroups { - lappend allchoices_originalcase {*}$clist - } - set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] - - if {$has_choices} { - if {$help ne ""} {append help \n} - if {[dict get $arginfo -nocase]} { - set casemsg " (case insensitive)" - set allchoices_prefixcalc [list {*}[string tolower $allchoices_originalcase] {*}$choiceprefixreservelist] - } else { - set casemsg " (case sensitive)" - set allchoices_prefixcalc [list {*}$allchoices_originalcase {*}$choiceprefixreservelist] - } - if {[dict get $arginfo -choiceprefix]} { - set prefixmsg " (choice prefix allowed)" - } else { - set prefixmsg "" - } - set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] - set choiceinfodict [Dict_getdef $arginfo -choiceinfo {}] - set formattedchoices [dict create] ;#use dict rather than array to preserve order - append help " Choices$prefixmsg$casemsg" - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - if {$choicemultiple_max == -1} { - append help \n " The value can be a list of $choicemultiple_min or more of these choices" - } else { - if {$choicemultiple_min eq $choicemultiple_max} { - append help \n " The value must be a list of $choicemultiple_min of these choices" - } else { - append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" - } - } - } - if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c [join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } else { - #set formattedchoices $choicegroups - #set formattedchoices [dict get $arginfo -choices] - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c [join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } - } else { - if {[catch { - set trie [punk::trie::trieclass new {*}$allchoices_prefixcalc] - set idents [dict get [$trie shortest_idents ""] scanned] - if {[dict get $arginfo -nocase]} { - #idents were calculated on lcase - remap keys in idents to original casing - set actual_idents $idents - foreach ch $allchoices_originalcase { - if {![dict exists $idents $ch]} { - #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting - #The actual testing is done in get_dict - dict set actual_idents $ch [dict get $idents [string tolower $ch]] - } - } - set idents $actual_idents - #puts "-----" - #puts "idents $idents" - } - - $trie destroy - dict for {groupname clist} $choicegroups { - foreach c $clist { - if {$c in $choiceprefixdenylist} { - set shortestid $c - } else { - set shortestid [dict get $idents $c] - } - if {$shortestid eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $shortestid] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set mk " [join $markers {}]" - } else { - set mk "" - } - set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]$mk" - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - #puts "-- parsed:$parsedvalues arg:$arg c:$c" - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } errM]} { - #this failure can happen if -nocase is true and there are ambiguous entries - #e.g -nocase 1 -choices {x X} - puts stderr "prefix marking failed\n$errM" - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c [join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } else { - #set formattedchoices $choicegroups - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c[join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } - - } - } - set choicetable_objects [list] - set choicetable_footers [dict create] - dict for {groupname formatted} $formattedchoices { - set numcols $choicecolumns ;#todo - dynamic? - if {[llength $formatted] < $numcols} { - #don't show blank cells if single line of results - set numcols [llength $formatted] - } - if {$numcols > 0} { - if {$use_table} { - #risk of recursing - #TODO -title directly in list_as_table - set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] - lappend choicetable_objects $choicetableobj - $choicetableobj configure -title $CLR(groupname)$groupname - #append help \n[textblock::join -- " " [$choicetableobj print]] - } else { - if {$groupname ne ""} { - append help \n \n "$CLR(groupname)Group: $groupname$RST" - } else { - append help \n - } - append help \n [join $formatted \n] - } - } else { - #we were given an empty set of choices. - #probably an error in the definition - but could happen if dynamically generated. - #(e.g ensemble where unknown mechanism is used for subcommands?) - #better to just display that there were none rather than totally break the usage output. - if {$usetable} { - #these will be displayed after all table entries - if {$groupname eq ""} { - dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" - } else { - dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" - } - } else { - if {$groupname eq ""} { - append help \n " " $CLR(errormsg)(no choices defined)$RST - } else { - append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST - } - } - } - } - set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width - foreach obj $choicetable_objects { - dict lappend twidths_by_colcount [$obj column_count] [$obj width] - } - foreach obj $choicetable_objects { - set cols [$obj column_count] - set widths [dict get $twidths_by_colcount $cols] - set max [tcl::mathfunc::max {*}$widths] - $obj configure -minwidth $max ;#expand smaller ones - set i 0 - while {$i < $cols} { - #keep text aligned left on expanded tables - $obj configure_column $i -blockalign left - incr i - } - - append help \n[textblock::join -- " " [$obj print]] - #set ansititle [dict get [$obj configure -title] value] - $obj destroy - } - if {[dict size $choicetable_footers]} { - foreach groupname [dict keys $formattedchoices] { - if {[dict exists $choicetable_footers $groupname]} { - append help \n [dict get $choicetable_footers $groupname] - } - } - } - - #review. use -type to restrict additional choices - may be different to values in the -choices - if {![dict get $arginfo -choicerestricted]} { - #when -choicemultiple - the -type refers to each selection - if {[dict get $arginfo -type] eq "string"} { - append help "\n (values not in defined choices are allowed)" - } else { - append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" - } - } - } - if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { - if {$is_multiple} { - set argshow "?${argshow}...?" - } else { - set argshow "?${argshow}?" - } - } else { - if {$is_multiple} { - set argshow "${argshow}..." - } - } - set typeshow [dict get $arginfo -type] - if {$typeshow eq "none"} { - set typeshow "$typeshow $soloflag" - } - if {[dict exists $arginfo -minsize]} { - append typeshow \n "-minsize [dict get $arginfo -minsize]" - } - if {[dict exists $arginfo -maxsize]} { - append typeshow \n "-maxsize [dict get $arginfo -maxsize]" - } - if {[dict exists $arginfo -range]} { - append typeshow \n "-range [dict get $arginfo -range]" - } - - if {$use_table} { - $t add_row [list $argshow $typeshow $default $multiple $help] - if {$arg eq $badarg} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG - } elseif {$arg in $goodargs} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $A_GOODARG - } - } else { - #review - formatting will be all over the shop due to newlines in typesshow, help - set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" - if {$arg eq $badarg} { - set arghelp [punk::ansi::ansiwrap -rawansi $A_BADARG $arghelp] - } elseif {$arg in $goodargs} { - set arghelp [punk::ansi::ansiwrap -rawansi $A_GOODARG $arghelp] - } - foreach ln [split $help \n] { - append arghelp " $ln" \n - } - lappend errlines $arghelp - } - } - - # ------------------------------------------------------------------------------------------------------- - # if the argument class can accept unnamed arguments (or if opts accepts unspecified flags) - display an indication - # ------------------------------------------------------------------------------------------------------- - switch -- $argumentclass { - leaders - values { - if {$argumentclass eq "leaders"} { - set class_unnamed LEADER_UNNAMED - set class_max LEADER_MAX - set class_required LEADER_REQUIRED - set class_directive_defaults LEADERSPEC_DEFAULTS - } else { - set class_unnamed VAL_UNNAMED - set class_max VAL_MAX - set class_required VAL_REQUIRED - set class_directive_defaults VALSPEC_DEFAULTS - } - if {[dict get $form_dict $class_unnamed]} { - set valmax [dict get $form_dict $class_max] - #set valmin [dict get $form_dict VAL_MIN] - if {$valmax eq ""} { - set valmax -1 - } - if {$valmax == -1} { - set possible_unnamed -1 - } else { - set possible_unnamed [expr {$valmax - [llength [dict get $form_dict $class_required]]}] - if {$possible_unnamed < 0} { - set possible_unnamed 0 - } - } - if {$possible_unnamed == -1 || $possible_unnamed > 0} { - #Note 'multiple' is always empty here as each unnamed is assigned to its own positional index - if {$possible_unnamed == 1} { - set argshow ?? - } else { - set argshow ?...? - } - set tp [dict get $form_dict $class_directive_defaults -type] - if {[dict exists $form_dict $class_directive_defaults -default]} { - set default [dict get $form_dict $class_directive_defaults -default] - } else { - set default "" - } - if {$use_table} { - $t add_row [list "$argshow" $tp $default "" ""] - } else { - set arghelp "[a+ bold]$argshow$RST TYPE:$tp DEFAULT:$default\n" - lappend errlines $arghelp - } - } - } - } - opts { - #display row to indicate if -any|-arbitrary true - - #review OPTSPEC_DEFAULTS -multiple ? - if {[dict get $form_dict OPT_ANY]} { - set argshow "?...?" - set tp [dict get $form_dict OPTSPEC_DEFAULTS -type] - if {[dict exists $form_dict OPTSPEC_DEFAULTS -default]} { - set default [dict get $form_dict OPTSPEC_DEFAULTS -default] - } else { - set default "" - } - if {$use_table} { - $t add_row [list "$argshow" $tp $default "" ""] - } else { - set arghelp "[a+ bold]$argshow$RST TYPE:$tp DEFAULT:$default\n" - lappend errlines $arghelp - } - } - } - } - - } ;#end foreach argumentclass - } ;#end is_custom_argdisplay - - if {$use_table} { - $t configure -show_hseps 0\ - -show_header 1\ - -ansibase_body $CLR(ansibase_body)\ - -ansibase_header $CLR(ansibase_header)\ - -ansiborder_header $CLR(ansiborder)\ - -ansiborder_body $CLR(ansiborder) - - $t configure -maxwidth 80 ;#review - if {$returntype ne "tableobject"} { - append errmsg [$t print] - #returntype of table means just the text of the table - $t destroy - } - } else { - append errmsg [join $errlines \n] - } - } errM]} { - append errmsg \n - append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n - append errmsg "$errM" \n - append errmsg "$::errorInfo" - catch {$t destroy} - - } - set arg_error_isrunning 0 - if {$use_table} { - #assert returntype is one of table, tableobject - set result $errmsg ;#default if for some reason table couldn't be used - if {$returntype eq "tableobject"} { - if {[info object isa object $t]} { - set result $t - } - } - } else { - set result $errmsg - } - if {$as_error} { - #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. - #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) - uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] - } else { - return $result - } - } - - - lappend PUNKARGS [list { - @dynamic - @id -id ::punk::args::usage - @cmd -name punk::args::usage -help\ - "Return usage information for a command identified by an id. - - This will only work for commands where a punk::args definition exists - for the command and an id has been defined for it. The id for custom - help for a command should match the fully qualified name of the command. - - Many commands (such as ensembles and oo objects) may have argument - documentation generated dynamically and may not yet have an id. - IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. - - Generally punk::ns::arginfo (aliased as i in the punk shell) should - be used in preference - as it will search for a documentation - mechanism and call punk::args::usage as necessary. - " - -return -default table -choices {string table tableobject} - }\ - {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}}\ - {${[punk::args::resolved_def -types opts ::punk::args::resolved_def -form]}}\ - { - - @values -min 0 -max 1 - id -help\ - "Exact id. - Will usually match the command name" - }] - proc usage {args} { - #lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received - lassign [dict values [punk::args::parse $args withid ::punk::args::usage]] leaders opts values received - set id [dict get $values id] - set real_id [real_id $id] - if {$real_id eq ""} { - error "punk::args::usage - no such id: $id" - } - #-scheme punk_info ?? - arg_error "" [punk::args::get_spec $real_id] {*}$opts -aserror 0 - } - - lappend PUNKARGS [list { - @id -id ::punk::args::get_by_id - @cmd -name punk::args::get_by_id - @values -min 1 - id - arglist -type list -help\ - "list containing arguments to be parsed as per the - argument specification identified by the supplied id." - }] - - - #deprecate? - proc get_by_id {id arglist} { - set definitionlist [punk::args::raw_def $id] - if {[llength $definitionlist] == 0} { - error "punk::args::get_by_id - no such id: $id" - } - #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] - tailcall ::punk::args::get_dict $definitionlist $arglist - } - - #consider - - #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) - #parse ?-flag val?... -- $arglist withid $id - #parse ?-flag val?... -- $arglist withdef $def ?$def?... - - #an experiment.. ideally we'd like arglist at the end? - #parse_withid ?-flag val?.. $id $arglist - #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? - #no possible equivalent for parse_withdef ??? - - lappend PUNKARGS [list { - @id -id ::punk::args::parse - @cmd -name punk::args::parse -help\ - "parse and validate command arguments based on a definition. - - In the 'withid' form the definition is a pre-existing record that has been - created with ::punk::args::define, or indirectly by adding a definition to - the PUNKARGS variable in a namespace which is then registered in - punk::args::register::NAMESPACES, or by a previous call to punk::parse - using 'withdef' and a definition block containing an @id -id directive. - - In the 'withdef' form - the definition is created on the first call and - cached thereafter, if the id didn't already exist. - - form1: parse $arglist ?-flag val?... withid $id - form2: parse $arglist ?-flag val?... withdef $def ?$def? - see punk::args::define - - Returns a dict of information regarding the parsed arguments - example of basic usage for single option only: - punk::args::define { - @id -id ::myns::myfunc - @cmd -name myns::myfunc - @leaders -min 0 -max 0 - @opts - -configfile -type existingfile - #type none makes it a solo flag - -verbose -type none - @values -min 0 -max 0 - } - proc myfunc {args} { - set argd [punk::args::parse $args withid ::myns::myfunc] - lassign [dict values $argd] leaders opts values received solos - if {[dict exists $received] -configfile} { - puts \"have option for existing file [dict get $opts -configfile]\" - } - } - The leaders, opts, values keys in the parse result dict are proper dicts. - The received key is dict-like but can have repeated keys for arguments than can - accept multiples. The value for each received element is the ordinal position. - The solos key refers to a list of solo flags received (those specified with - -type none). This is generally only useful to assist in passing arguments on - to another procedure which also requires solos, because the opts dict contains - solo flags with a 1 value or a list of 1's if it was a solo with -multiple true - specified. - " - @form -form {withid withdef} - @leaders -min 1 -max 1 - arglist -type list -optional 0 -help\ - "Arguments to parse - supplied as a single list" - - @opts - -form -type list -default * -help\ - "Restrict parsing to the set of forms listed. - Forms are the orthogonal sets of arguments a - command can take - usually described in 'synopsis' - entries." - #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance - #todo - configurable per interp/namespace - -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} - - @values -min 2 - - @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" - @values -max 2 - withid -type literal -help\ - "The literal value 'withid'" - id -type string -help\ - "id of punk::args definition for a command" - - - @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" - withdef -type literal -help\ - "The literal value 'withdef'" - - #todo - make -dynamic obsolete - use @dynamic directive instead - def -type string -multiple 1 -optional 0 -help\ - "Each remaining argument is a block of text - defining argument definitions. - As a special case, -dynamic may be - specified as the 1st 2 arguments. These are - treated as an indicator to punk::args about - how to process the definition." - - }] - proc parse {args} { - #puts "punk::args::parse --> '$args'" - set tailtype "" ;#withid|withdef - if {[llength $args] < 3} { - #error "punk::args::parse - invalid call. < 3 args" - punk::args::parse $args withid ::punk::args::parse - } - set opts_and_vals $args - set parseargs [lpop opts_and_vals 0] - - set opts [list] - set values [list] - for {set i 0} {$i < [llength $opts_and_vals]} {incr i} { - if {[string match -* [lindex $opts_and_vals $i]]} { - if {[catch { - lappend opts [lpop opts_and_vals 0] [lpop opts_and_vals 0] - }]} { - #unhappy path - not enough options - #review - which form of punk::args::parse? - punk::args::parse $args withid ::punk::args::parse - } - incr i -1 - #lappend opts $a [lindex $opts_and_vals $i] - } else { - break - } - } - #set values [lrange $opts_and_vals $i end] - set values $opts_and_vals - #puts "---values: $values" - set tailtype [lindex $values 0] - set tailargs [lrange $values 1 end] - - - #set split [lsearch -exact $tailargs withid] - #if {$split < 0} { - # set split [lsearch -exact $tailargs withdef] - # if {$split < 0} { - # #punk::args::usage arg_error? - # #error "punk::args::parse - invalid call. keyword withid|withdef required" - # punk::args::parse $args withid ::punk::args::parse - # } else { - # set tailtype withdef - #} - #} else { - # set tailtype withid - #} - #set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. - - - #if {[llength $opts] % 2} { - #error "punk::args::parse Even number of -flag val pairs required after arglist" - #} - - #Default the -errorstyle to enhanced - # (slowest on unhappy path - but probably clearest for playing with new APIs interactively) - # - application devs should distribute a config file with an errorstyle override if desired. - # - devs who prefer a different default for interactive use should create a config for it. (todo) - set defaultopts [dict create\ - -form {*}\ - -errorstyle enhanced\ - ] - - #todo - load override_errorstyle from configuration - #dict set defaultopts -errorstyle $ - #puts "def: $defaultopts opts: $opts" - set opts [dict merge $defaultopts $opts] - dict for {k v} $opts { - switch -- $k { - -form - -errorstyle { - } - default { - #punk::args::usage $args withid ::punk::args::parse ?? - #error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" - punk::args::parse $args withid ::punk::args::parse - } - } - } - switch -- $tailtype { - withid { - if {[llength $tailargs] != 1} { - #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - punk::args::parse $args withid ::punk::args::parse - } - set id [lindex $tailargs 0] - #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" - #puts stdout "punk::args::parse '$parseargs' withid $id, options: $opts" - set deflist [raw_def $id] - if {[llength $deflist] == 0} { - error "punk::args::parse - no such id: $id" - } - } - withdef { - set deflist $tailargs - if {[llength $deflist] < 1} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" - #puts stdout "punk::args::parse '$parseargs' with [llength $deflist] definition blocks, options: $opts" - } - default { - error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" - } - } - try { - #puts stdout "parse --> get_dict $parseargs -form [dict get $opts -form]" - set result [punk::args::get_dict $deflist $parseargs -form [dict get $opts -form]] - } trap {PUNKARGS VALIDATION} {msg erroropts} { - set opt_errorstyle [dict get $opts -errorstyle] - - #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - - - set ecode [dict get $erroropts -errorcode] - #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... - set msg [string map [list %caller% [Get_caller]] $msg] - switch -- $opt_errorstyle { - minimal { - return -options [list -code error -errorcode $ecode] $msg - } - basic { - #No table layout - unix manpage style - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg -form [dict get $opts -form]] - } - return -options [list -code error -errorcode $ecode] $msg - } - standard { - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] - } - return -options [list -code error -errorcode $ecode] $msg - } - enhanced { - set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below) - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - set ecode_summary [lrange $ecode 0 2] - if {$badarg ne ""} { - lappend ecode_summary -badarg $badarg - } - catch {package require punk::lib} - if {[package provide punk::lib] ne ""} { - append msg \n [punk::lib::showdict -roottype list $estack */*] - } - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] - append msg \n "::errorCode summary: $ecode_summary" - return -options [list -code error -errorcode $ecode] $msg - } else { - #why? todo? - append msg \n "(enhanced error information unavailable)" - append msg \n "::errorCode summary: $ecode_summary" - return -options [list -code error -errorcode $ecode] $msg - } - } - debug { - puts stderr "errorstyle debug not implemented" - return -options [list -code error -errorcode $ecode] $msg - } - default { - puts stderr "errorstyle $opt_errorstyle not recognised: expected one of minimal basic standard enhanced debug" - return -options [list -code error -errorcode $ecode] $msg - } - } - } trap {PUNKARGS} {msg erropts} { - append msg \n "Unexpected PUNKARGS error" - return -options [list -code error -errorcode $ecode] $msg - } trap {} {msg erroropts} { - #review - #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. - #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. - throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] - } - return $result - } - proc parseXXX {args} { - #no solo flags allowed for parse function itself. (ok for arglist being parsed) - set opts [dict create] ;#repeated flags will override earlier. That's ok here. - set arglist {} - set got_arglist 0 - set tailtype "" ;#withid|withdef - set id "" - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {[string match -* $a]} { - dict set opts $a [lindex $args $i+1] - incr i - } else { - set arglist $a - set got_arglist 1 - set tailtype [lindex $args $i+1] - if {$tailtype eq "withid"} { - if {[llength $args] != $i+3} { - error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - } - set id [lindex $args $i+2] - break - } elseif {$tailtype eq "withdef"} { - if {[llength $args] < $i+3} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - set deflist [lrange $args $i+2 end] - break - } else { - error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" - } - } - } - if {!$got_arglist} { - error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." - } - #assert tailtype eq withid|withdef - if {$tailtype eq "withid"} { - #assert $id was provided - return "parse [llength $arglist] args withid $id, options:$opts" - } else { - #assert llength deflist >=1 - return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" - } - #TODO - } - - - #return number of values we can assign to cater for variable length clauses such as {"elseif" expr "?then?" body} - #review - efficiency? each time we call this - we are looking ahead at the same info - proc _get_dict_can_assign_value {idx values nameidx names namesreceived formdict} { - set ARG_INFO [dict get $formdict ARG_INFO] - set all_remaining [lrange $values $idx end] - set thisname [lindex $names $nameidx] - set thistype [dict get $ARG_INFO $thisname -type] - set tailnames [lrange $names $nameidx+1 end] - - #todo - work backwards with any (optional or not) literals at tail that match our values - and remove from assignability. - set ridx 0 - foreach clausename [lreverse $tailnames] { - #puts "=============== clausename:$clausename all_remaining: $all_remaining" - set typelist [dict get $ARG_INFO $clausename -type] - if {[lsearch $typelist literal*] == -1} { - break - } - set max_clause_length [llength $typelist] - if {$max_clause_length == 1} { - #basic case - set alloc_ok 0 - #set v [lindex $values end-$ridx] - set v [lindex $all_remaining end] - set tp [lindex $typelist 0] - #review - ignore ?literal? and ?literal(xxx)? when clause-length == 1? (should raise error during definition instead? - #we shouldn't have an optional clause member if there is only one member - the whole name should be marked -optional true instead. - set tp [string trim $tp ?] - if {[string match literal* $tp]} { - set litinfo [string range $tp 7 end] ;#get bracketed part if of form literal(xxx) - if {[string match (*) $litinfo]} { - set match [string range $litinfo 1 end-1] - } else { - #plain "literal" without bracketed specifier - match to argument name - set match $clausename - } - if {$v eq $match} { - set alloc_ok 1 - lpop all_remaining - if {![dict get $ARG_INFO $clausename -multiple]} { - lpop tailnames - } - } else { - #break - } - } else { - #break - } - if {!$alloc_ok} { - if {![dict get $ARG_INFO $clausename -optional]} { - break - } - } - } else { - #review - we assume here that we don't have a set of clause-members where all are marked optional (?membertype?) - #This is better caught during definition. - #e.g rn = {elseif expr (?then?) body} typelist = {literal expr ?literal? script} - #set cvals [lrange $values end-$ridx end-[expr {$ridx + $max_clause_length-1}]] - set cvals [lrange $values end-[expr {$ridx + $max_clause_length-1}] end-$ridx] - set rcvals [lreverse $cvals] - set alloc_count 0 - #clause name may have more entries than types - extras at beginning are ignored - set rtypelist [lreverse $typelist] - set rclausename [lrange [lreverse $clausename] 0 [llength $typelist]-1] - #assert length of rtypelist >= $rclausename - set alloc_ok 0 - set reverse_type_index 0 - foreach tp $rtypelist membername $rclausename { - #(membername may be empty if not enough elements) - #set rv [lindex $rcvals end-$alloc_count] - set rv [lindex $all_remaining end-$alloc_count] - if {[string match {\?*\?} $tp]} { - set clause_member_optional 1 - } else { - set clause_member_optional 0 - } - set tp [string trim $tp ?] - if {[string match literal* $tp]} { - set litinfo [string range $tp 7 end] - if {[string match (*) $litinfo]} { - set match [string range $litinfo 1 end-1] - } else { - #if membername empty - equivalent to "literal()" - matches empty string literal - #edgecase - possibly? no need for empty-string literals - but allow it without error. - set match $membername - } - if {$rv eq $match} { - set alloc_ok 1 ;#we need at least one literal-match to set alloc_ok - incr alloc_count - } else { - if {$clause_member_optional} { - # - } else { - set alloc_ok 0 - break - } - } - } else { - if {$clause_member_optional} { - #review - optional non-literal makes things harder.. - #we don't want to do full type checking here - but we now risk allocating an item that should actually - #be allocated to the previous value - set prev_type [lindex $rtypelist $reverse_type_index+1] - if {[string match literal* $prev_type]} { - set litinfo [string range $prev_type 7 end] - if {[string match (*) $litinfo]} { - set match [string range $litinfo 1 end-1] - } else { - #prev membername - set match [lindex $rclausename $reverse_type_index+1] - } - if {$rv ne $match} { - #current val doesn't match previous type - allocate here - incr alloc_count - } - } else { - #no literal to anchor against.. - incr alloc_count - } - } else { - #allocate regardless of type - we're only matching on arity and literal positioning here. - #leave final type-checking for later. - incr alloc_count - } - } - incr reverse_type_index - } - if {$alloc_ok && $alloc_count > 0} { - #set n [expr {$alloc_count -1}] - #set all_remaining [lrange $all_remaining end-$n end] - set all_remaining [lrange $all_remaining 0 end-$alloc_count] - #don't lpop if -multiple true - if {![dict get $ARG_INFO $clausename -multiple]} { - lpop tailnames - } - } else { - break - } - } - incr ridx - } - set num_remaining [llength $all_remaining] - - if {[dict get $ARG_INFO $thisname -optional] || ([dict get $ARG_INFO $thisname -multiple] && $thisname in $namesreceived)} { - #todo - check -multiple for required min/max (not implemented: make -multiple accept ?) - #thisname already satisfied, or not required - set tail_needs 0 - foreach t $tailnames { - if {![dict get $ARG_INFO $t -optional]} { - set min_clause_length [llength [lsearch -all -not [dict get $ARG_INFO $t -type] {\?*\?}]] - incr tail_needs $min_clause_length - } - } - set all_remaining [lrange $all_remaining 0 end-$tail_needs] - } - - #thistype - set alloc_ok 1 - set alloc_count 0 - set resultlist [list] - set n [expr {[llength $thistype]-1}] - #name can have more or less items than typelist - set thisnametail [lrange $thisname end-$n end] - foreach tp $thistype membername $thisnametail { - set v [lindex $all_remaining $alloc_count] - if {[string match {\?*\?} $tp]} { - set clause_member_optional 1 - } else { - set clause_member_optional 0 - } - set tp [string trim $tp ?] - if {[string match literal* $tp]} { - set litinfo [string range $tp 7 end] - if {[string match (*) $litinfo]} { - set match [string range $litinfo 1 end-1] - } else { - set match $membername - } - if {$v eq $match} { - if {$clause_member_optional && $alloc_count >= [llength $all_remaining]} { - lappend resultlist "" - } else { - lappend resultlist $v - incr alloc_count - } - } else { - if {$clause_member_optional} { - #todo - configurable default for optional clause members? - lappend resultlist "" - } else { - set alloc_ok 0 - break - } - } - } else { - if {$clause_member_optional} { - if {$alloc_count >= [llength $all_remaining]} { - lappend resultlist "" - } else { - lappend resultlist $v - incr alloc_count - } - } else { - lappend resultlist $v - incr alloc_count - } - } - if {$alloc_count > [llength $all_remaining]} { - set alloc_ok 0 - break - } - } - if {$alloc_ok} { - set d [dict create consumed $alloc_count resultlist $resultlist] - } else { - set d [dict create consumed 0 resultlist {}] - } - #puts ">>>> _get_dict_can_assign_value $d" - return $d - } - - #todo? - a version of get_dict that directly supports punk::lib::tstr templating - #rename get_dict - # - - #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 get_dict {deflist rawargs args} { - #see arg_error regarding considerations around unhappy-path performance - - if {[llength $args] % 2 != 0} { - error "punk::args::get_dict args must be a dict of option value pairs" - } - set defaults [dict create\ - -form *\ - ] - set opts [dict merge $defaults $args] - dict for {k v} $opts { - switch -- $k { - -form {} - default { - error "punk::args::get_dict Unexpected option '$k' Known options -form" - } - } - } - - - #*** !doctools - #[call [fun get_dict] [arg deflist] [arg rawargs] [arg args]] - #[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 values - #[para]ARGUMENTS: - #[list_begin arguments] - #[arg_def list-of-multiline-string deflist] - #[para] These are blocks 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 defining a flag 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 - #[para]Each optionspec line defining a positional argument is of the form: - #[para]argumentname -key val -ky2 val2... - #[para]where the valid keys for each option specification are: -default -type -range -choices - #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value - #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. - #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. - #[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, - #but it could be a manually constructed list of values made for example from positional args defined in the proc. - #[list_end] - #[para] - - #consider line-processing example below for which we need info complete to determine record boundaries - #punk::args::get_dict [list { - # @opts - # -opt1 -default {} - # -opt2 -default { - # etc - # } - # @values -multiple 1 - #}] $args - - - - - #rawargs: args values to be parsed - #we take a definition list rather than resolved argspecs - because the definition could be dynamic - - #if definition has been seen before, - #define will either return a permanently cached argspecs (-dynamic 0) - or - # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. - set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]] - - # ----------------------------------------------- - # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) - tcl::dict::with argspecs {} ;#turn keys into vars - #e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info,id_info,form_names - # ----------------------------------------------- - set opt_form [dict get $opts -form] - if {$opt_form eq "*"} { - set selected_forms $form_names - } elseif {[string is integer -strict $opt_form]} { - if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { - error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set selected_forms [list [lindex $form_names $opt_form]] - } else { - if {$opt_form ni $form_names} { - error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set selected_forms [list $opt_form] - } - - - #puts "-arg_info->$arg_info" - set flagsreceived [list] ;#for checking if required flags satisfied - set solosreceived [list] - set multisreceived [list] - #secondary purpose: - #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 ? - - # -- --- --- --- - # Handle leading positionals - # todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ? - - #todo - handle multiple fids? - set fid [lindex $selected_forms 0] - set formdict [dict get $FORMS $fid] - tcl::dict::with formdict {} - #populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc - if {$VAL_MIN eq ""} { - set valmin 0 - #set VAL_MIN 0 - foreach v $VAL_NAMES { - if {![dict get $ARG_INFO $v -optional]} { - # todo variable clause lengths (items marked optional in types using leading&trailing questionmarks) - # e.g -types {a ?xxx?} - #this has one required and one optional - set typelist [dict get $ARG_INFO $v -type] - set clause_length 0 - foreach t $typelist { - if {![string match {\?*\?} $t]} { - incr clause_length - } - } - incr valmin $clause_length - } - } - } else { - set valmin $VAL_MIN - } - - set pre_values {} - - set argnames [tcl::dict::keys $ARG_INFO] - #set optnames [lsearch -all -inline $argnames -*] - #JJJ - set all_opts [list] - set lookup_optset [dict create] - foreach optset $OPT_NAMES { - set optmembers [split $optset |] - lappend all_opts {*}$optmembers - foreach opt $optmembers { - dict set lookup_optset $opt $optset - } - } - set ridx 0 - set rawargs_copy $rawargs - set remaining_rawargs $rawargs - set leader_posn_name "" - set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) - set is_multiple 0 ;#last leader may be multi - #consider for example: LEADER_NAMES {"k v" "a b c" x} - #(i.e clause-length of 2 3 and 1) - #This will take 6 raw leaders to fill in the basic case that all are -optional 0 and -multiple 0 - set named_leader_args_max 0 - foreach ln $LEADER_NAMES { - incr named_leader_args_max [llength $ln] - } - - #set id [dict get $argspecs id] - #if {$id eq "::if"} { - #puts stderr "::if" - #puts stderr "get_dict--> remaining_rawargs: $remaining_rawargs" - #} - set nameidx 0 - if {$LEADER_MAX != 0} { - for {set ridx 0} {$ridx < [llength $rawargs]} {incr ridx} { - set r [lindex $rawargs $ridx] - if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { - break - } - if {[llength $LEADER_NAMES] && $nameidx == [llength $LEADER_NAMES]-1} { - #at last named leader - set leader_posn_name [lindex $LEADER_NAMES $nameidx] - if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { - set is_multiple 1 - } - } elseif {$ridx > $named_leader_args_max-1} { - #beyond names - retain name if -multiple was true - if {!$is_multiple} { - set leader_posn_name "" - } - } else { - set leader_posn_name [lindex $LEADER_NAMES $nameidx] ;#may return empty string - } - if {$OPT_MAX ne "0" && $r eq "--"} { - #review end of opts marker: '--' can't be a leader (but can be a value) - break - } - - #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option - if {$OPT_MAX ne "0" && [tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { - set matchopt [::tcl::prefix::match -error {} $all_opts $r] - if {$matchopt ne ""} { - #flaglike matches a known flag - don't treat as leader - break - } - if {$leader_posn_name ne ""} { - #false alarm - #there is a named leading positional for this position - #The flaglooking value doesn't match an option - so treat as a leader - incr ridx -1 - foreach v $leader_posn_name { - incr ridx - lappend pre_values [lpop remaining_rawargs 0] - } - if {!$is_multiple} { - incr nameidx - } - dict incr leader_posn_names_assigned $leader_posn_name - #incr ridx - continue - } else { - break - } - } - - #for each branch - break or lappend - if {$leader_posn_name ne ""} { - #todo - variable clauselengths e.g 'if' command which has optional 'then' and 'else' "noise words" - set clauselength [llength $leader_posn_name] - if {$leader_posn_name ni $LEADER_REQUIRED} { - #optional leader - - #most adhoc arg processing will allocate based on number of args rather than matching choice values first - #(because a choice value could be a legitimate data value) - - #review - option to process in this manner? - #first check if the optional leader value is a match for a choice ? - #if {[dict exists $arg_info $leader_posn_name -choices]} { - # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] [lindex $remaining_rawargs 0]] - # if {$vmatch ne ""} { - # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values - # lappend pre_values [lpop remaining_rawargs 0] - # incr ridx - # continue - # } - #} - if {[llength $remaining_rawargs] < $clauselength} { - #not enough remaining args to fill even this optional leader - #rather than raise error here - perform our break (for end of leaders) and let the code below handle it - break - } - - #check if enough remaining_rawargs to fill any required values - if {$valmin > 0 && [llength $remaining_rawargs] - $clauselength < $valmin} { - break - } - - #leadername may be a 'clause' of arbitrary length (e.g {"key val"} or {"key val etc"}) - incr ridx -1 - foreach v $leader_posn_name { - incr ridx - lappend pre_values [lpop remaining_rawargs 0] - } - if {!$is_multiple} { - incr nameidx - } - dict incr leader_posn_names_assigned $leader_posn_name - } else { - #required - if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { - #already accepted at least one value - requirement satisfied - now equivalent to optional - if {[llength $remaining_rawargs] < $clauselength} { - #not enough remaining args to fill even this optional leader - #rather than raise error here - perform our break (for end of leaders) and let the code below handle it - break - } - - if {$valmin > 0 && [llength $remaining_rawargs] - $clauselength < $valmin} { - break - } - } - #if we didn't break - requirement is not yet satisfied, or is satisfied but still enough remaining_rawargs for required values - #we still need to check if enough values for the leader itself - if {[llength $remaining_rawargs] < $clauselength} { - #not enough remaining args to fill *required* leader - break - } - - incr ridx -1 - foreach v $leader_posn_name { - incr ridx - lappend pre_values [lpop remaining_rawargs 0] - } - if {!$is_multiple} { - incr nameidx - } - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #unnamed leader - if {$LEADER_MIN ne "" } { - if {$ridx > $LEADER_MIN-1} { - if {$LEADER_MAX ne "" && $ridx == $LEADER_MAX} { - break - } else { - if {$valmin > 0} { - if {[llength $remaining_rawargs] > $valmin} { - lappend pre_values [lpop remaining_rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } else { - break - } - } else { - lappend pre_values [lpop remaining_rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } - } else { - #haven't reached LEADER_MIN - lappend pre_values [lpop remaining_rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #review - if is_multiple, keep going if enough remaining_rawargs for values? - break - } - } - - #incr ridx - } ;# end foreach r $rawargs_copy - } - - set argstate $ARG_INFO ;#argstate may have entries added - set arg_checks $ARG_CHECKS - - if {$LEADER_MIN eq ""} { - set leadermin 0 - } else { - set leadermin $LEADER_MIN - } - if {$LEADER_MAX eq ""} { - set leadermax -1 - } else { - set leadermax $LEADER_MAX - } - - if {$VAL_MAX eq ""} { - set valmax -1 - } else { - set valmax $VAL_MAX - } - - #assert leadermax leadermin are numeric - #assert - remaining_rawargs has been reduced by leading positionals - - set opts [dict create] ;#don't set to OPT_DEFAULTS here -#JJJ - #set id [dict get $argspecs id] - #if {$id eq "::if"} { - #puts stderr "::if" - #puts stderr "get_dict--> pre_values: $pre_values" - #puts stderr "get_dict--> remaining_rawargs: $remaining_rawargs" - #} - - set leaders [list] - set arglist {} - set post_values {} - #valmin, valmax - #puts stderr "remaining_rawargs: $remaining_rawargs" - #puts stderr "argstate: $argstate" - if {$OPT_MAX ne "0" && [lsearch $remaining_rawargs -*] >= 0} { - #at least contains flaglike things.. - set maxidx [expr {[llength $remaining_rawargs] -1}] - if {$valmax == -1} { - set vals_total_possible [llength $remaining_rawargs] - set vals_remaining_possible $vals_total_possible - } else { - set vals_total_possible $valmax - set vals_remaining_possible $vals_total_possible - } - for {set i 0} {$i <= $maxidx} {incr i} { - set a [lindex $remaining_rawargs $i] - set remaining_args_including_this [expr {[llength $remaining_rawargs] - $i}] - #lowest valmin is 0 - if {$remaining_args_including_this <= $valmin} { - # if current arg is -- it will pass through as a value here - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - break - } - - #exlude argument with whitespace from being a possible option e.g dict - if {[tcl::string::match -* $a] && !([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { - if {$a eq "--"} { - #remaining num args <= valmin already covered above - if {$valmax != -1} { - #finite max number of vals - if {$remaining_args_including_this == $valmax} { - #assume it's a value. - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - } else { - #assume it's an end-of-options marker - lappend flagsreceived -- - set arglist [lrange $remaining_rawargs 0 $i] - set post_values [lrange $remaining_rawargs $i+1 end] - } - } else { - #unlimited number of post_values accepted - #treat this as eopts - we don't care if remainder look like options or not - lappend flagsreceived -- - set arglist [lrange $remaining_rawargs 0 $i] - set post_values [lrange $remaining_rawargs $i+1 end] - } - break - } else { - set opt [tcl::prefix match -error "" [list {*}$all_opts --] $a] - if {$opt eq "--"} {set opt ""} - if {[dict exists $lookup_optset $opt]} { - set fullopt [dict get $lookup_optset $opt] - } else { - set fullopt "" - } - if {$fullopt ne ""} { - #e.g when fullopt eq -fg|-foreground - #-fg is an alias , -foreground is the 'api' value for the result dict - #$fullopt remains as the key in the spec - set optmembers [split $fullopt |] - set api_opt [lindex $optmembers end] - - if {![tcl::dict::get $argstate $fullopt -prefix] && $a ni $optmembers} { - #attempt to use a prefix when not allowed - #review - by ending opts here - we dont' get the clearest error msgs - # may *sometimes* be better to raise a PUNKARGS VALIDATION (invalidoption) error - # (but it may actually be the first value that just happens to be flaglike) - #todo - check for subsequent valid flags or -- marker? - #consider for example 'file delete -f -- old.txt' - #If we just end option-processing, the punk::args parser would pass {-f -- old.txt} as values - #whereas the builtin file arg parser alerts that -f is a bad option - set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $all_opts" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $all_opts] -badarg $a -argspecs $argspecs]] $errmsg - #set arglist [lrange $remaining_rawargs 0 $i-1] - #set post_values [lrange $remaining_rawargs $i end] - #break - } - if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { - #non-solo - #check if it was actually a value that looked like a flag - if {$i == $maxidx} { - #if no optvalue following - assume it's a value - #(caller should probably have used -- before it) - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - break - } - - set flagval [lindex $remaining_rawargs $i+1] - if {[tcl::dict::get $argstate $fullopt -multiple]} { - #don't lappend to default - we need to replace if there is a default - if {$api_opt ni $flagsreceived} { - tcl::dict::set opts $api_opt [list $flagval] - } else { - tcl::dict::lappend opts $api_opt $flagval - } - if {$api_opt ni $multisreceived} { - lappend multisreceived $api_opt - } - } else { - tcl::dict::set opts $api_opt $flagval - } - #incr i to skip flagval - incr vals_remaining_possible -2 - if {[incr i] > $maxidx} { - set msg "Bad options for %caller%. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $fullopt index [expr {$i-1}]] -badarg $fullopt -argspecs $argspecs]] $msg - } - } else { - #solo - if {[tcl::dict::get $argstate $fullopt -multiple]} { - if {$api_opt ni $flagsreceived} { - #override any default - don't lappend to it - tcl::dict::set opts $api_opt 1 - } else { - tcl::dict::lappend opts $api_opt 1 - } - if {$api_opt ni $multisreceived} { - lappend multisreceived $fullopt - } - } else { - tcl::dict::set opts $api_opt 1 - } - incr vals_remaining_possible -1 - lappend solosreceived $api_opt ;#dups ok - } - lappend flagsreceived $api_opt ;#dups ok - } else { - #unmatched option flag - #comparison to valmin already done above - if {$valmax ne -1 && $remaining_args_including_this <= $valmax} { - #todo - look at optspec_default and see if solo/vs opt-val pair - #we may need to lookahead by 2 regarding valmax valmin - - #even with optany - assume an unknown within the space of possible values is a value - #unmatched option in right position to be considered a value - treat like eopts - #review - document that an unspecified arg within range of possible values will act like eopts -- - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - break - } - if {$OPT_ANY} { - set newval [lindex $remaining_rawargs $i+1] - #opt was unspecified but is allowed due to @opts -any|-arbitrary true - 'adhoc/passthrough' option - tcl::dict::set argstate $a $OPTSPEC_DEFAULTS ;#use default settings for unspecified opt - tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS - if {[tcl::dict::get $argstate $a -type] ne "none"} { - if {[tcl::dict::get $argstate $a -multiple]} { - tcl::dict::lappend opts $a $newval - if {$a ni $multisreceived} { - lappend multisreceived $a - } - } else { - tcl::dict::set opts $a $newval - } - if {[incr i] > $maxidx} { - set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg - #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a - } - incr vals_remaining_possible -2 - } else { - #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none - if {[tcl::dict::get $argstate $a -multiple]} { - if {![tcl::dict::exists $opts $a]} { - tcl::dict::set opts $a 1 - } else { - tcl::dict::lappend opts $a 1 - } - if {$a ni $multisreceived} { - lappend multisreceived $a - } - } else { - tcl::dict::set opts $a 1 - } - incr vals_remaining_possible -1 - lappend solosreceived $a - } - lappend flagsreceived $a ;#adhoc flag as supplied - } else { - if {[llength $OPT_NAMES]} { - set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" - } else { - set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any|-arbitrary false" - } - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg - #arg_error $errmsg $argspecs -badarg $fullopt - } - } - } - } else { - #not flaglike - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - break - } - } - #set values [list {*}$pre_values {*}$post_values] - set leaders $pre_values - set values $post_values - } else { - set leaders $pre_values - set values $remaining_rawargs - #set values [list {*}$pre_values {*}$remaining_rawargs] ;#no -flags detected - set arglist [list] - } - #set id [dict get $argspecs id] - #if {$id eq "::if"} { - #puts stderr "::if" - #puts stderr "get_dict--> arglist: $arglist" - #puts stderr "get_dict--> leaders: $leaders" - #puts stderr "get_dict--> values: $values" - #} - - #--------------------------------------- - set ordered_opts [dict create] - set unaliased_opts [lmap v $OPT_NAMES {lindex [split $v |] end}] - #unaliased_opts is list of 'api_opt' (handle aliases of form -a1|-a2|-api_opt e.g -fg|-foreground) - foreach o $unaliased_opts optset $OPT_NAMES { - if {[dict exists $opts $o]} { - dict set ordered_opts $o [dict get $opts $o] - } elseif {[dict exists $OPT_DEFAULTS $optset]} { - dict set ordered_opts $o [dict get $OPT_DEFAULTS $optset] - } - } - #add in possible arbitrary opts after the defined opts, due to @opts directive flag '-any|-arbitrary true' - dict for {o oval} $opts { - if {![dict exists $ordered_opts $o]} { - dict set ordered_opts $o $oval - } - } - set opts $ordered_opts - #--------------------------------------- - - - set positionalidx 0 ;#index for unnamed positionals (both leaders and values) - set leadername_multiple "" - set leadernames_received [list] - - set num_leaders [llength $leaders] - - #---------------------------------------- - #Establish firm leaders ordering - set leaders_dict [dict create] - foreach lname [lrange $LEADER_NAMES 0 $num_leaders-1] { - dict set leaders_dict $lname {} - } - set leaders_dict [dict merge $leaders_dict $LEADER_DEFAULTS] - #---------------------------------------- - - set start_position $positionalidx - set nameidx 0 - #MAINTENANCE - (*nearly*?) same loop logic as for value - for {set ldridx 0} {$ldridx < [llength $leaders]} {incr ldridx} { - set leadername [lindex $LEADER_NAMES $nameidx] - #incr nameidx - set ldr [lindex $leaders $ldridx] - if {$leadername ne ""} { - set typelist [tcl::dict::get $argstate $leadername -type] - if {[llength $typelist] == 1} { - set clauseval $ldr - } else { - set clauseval [list] - incr ldridx -1 - foreach t $typelist { - incr ldridx - if {$ldridx > [llength $leaders]-1} { - set msg "Bad number of leaders for %caller%. Received [llength $clauseval] values ('$clauseval') for '$leadername', but requires [llength $leadername] values" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength [llength $leadername] ] -argspecs $argspecs]] $msg - } - lappend clauseval [lindex $leaders $ldridx] - } - } - - if {[tcl::dict::get $argstate $leadername -multiple]} { - #if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { - # #current stored ldr equals defined default - don't include default in the list we build up - # tcl::dict::set leaders_dict $leadername [list $clauseval] ;#important to treat first element as a list - #} else { - # tcl::dict::lappend leaders_dict $leadername $clauseval - #} - if {$leadername in $leadernames_received} { - tcl::dict::lappend leaders_dict $leadername $clauseval - } else { - tcl::dict::set leaders_dict $leadername [list $clauseval] - } - set leadername_multiple $leadername - } else { - tcl::dict::set leaders_dict $leadername $clauseval - set leadername_multiple "" - incr nameidx - } - lappend leadernames_received $leadername - } else { - if {$leadername_multiple ne ""} { - set typelist [tcl::dict::get $argstate $leadername_multiple -type] - if {[llength $typelist] == 1} { - set clauseval $ldr - } else { - set clauseval [list] - incr ldridx -1 - foreach t $typelist { - incr ldridx - if {$ldridx > [llength $leaders]-1} { - set msg "Bad number of leaders for %caller%. Received [llength $clauseval] values ('$clauseval') for '$leadername_multiple', but requires [llength $leadername_multiple] values." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength [llength $leadername_multiple] ] -argspecs $argspecs]] $msg - } - lappend clauseval [lindex $leaders $ldridx] - } - } - tcl::dict::lappend leaders_dict $leadername_multiple $clauseval - #name already seen - but must add to leadernames_received anyway (as with opts and values) - lappend leadernames_received $leadername_multiple - } else { - if {$LEADER_UNNAMED} { - tcl::dict::set leaders_dict $positionalidx $ldr - tcl::dict::set argstate $positionalidx $LEADERSPEC_DEFAULTS - tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS - lappend leadernames_received $positionalidx - } else { - set msg "Bad number of leaders for %caller%. Received more leaders than can be assigned to argument names. (set '@leaders -unnamed true' to allow unnamed leaders)" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list toomanyarguments [llength $values] index $positionalidx] -argspecs $argspecs]] $msg - } - } - } - set positionalidx [expr {$start_position + $ldridx + 1}] - } - #----------------------------------------------------- - #satisfy test parse_withdef_leaders_no_phantom_default - foreach leadername [dict keys $leaders_dict] { - if {[string is integer -strict $leadername]} { - #ignore leadername that is a positionalidx - #review - always trailing - could use break? - continue - } - if {$leadername ni $leadernames_received && ![dict exists $LEADER_DEFAULTS $leadername]} { - #remove the name with empty-string default we used to establish fixed order of names - #The 'leaders' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default. - dict unset leaders_dict $leadername - } - } - #----------------------------------------------------- - - set validx 0 - set valname_multiple "" - set valnames_received [list] - - set num_values [llength $values] - #------------------------------------------ - #Establish firm values ordering - ## Don't set values_dict to VAL_DEFAULTS - or order of values_dict will be intermittently wrong based on whether values have defaults - ## set values_dict $val_defaults - set values_dict [dict create] - foreach valname [lrange $VAL_NAMES 0 $num_values-1] { - #set ALL valnames to lock in positioning - #note - later we need to unset any optional that had no default and was not received (no phantom default) - dict set values_dict $valname {} - } - set values_dict [dict merge $values_dict $VAL_DEFAULTS] - #------------------------------------------ - set nameidx 0 - set start_position $positionalidx - #MAINTENANCE - (*nearly*?) same loop logic as for leaders - for {set validx 0} {$validx < [llength $values]} {incr validx} { - set valname [lindex $VAL_NAMES $nameidx] - set val [lindex $values $validx] - if {$valname ne ""} { - set valtypelist [tcl::dict::get $argstate $valname -type] - - set assign_d [_get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES $valnames_received $formdict] - set consumed [dict get $assign_d consumed] - set resultlist [dict get $assign_d resultlist] - if {[tcl::dict::get $argstate $valname -optional]} { - if {$consumed == 0} { - incr validx -1 - set valname_multiple "" - incr nameidx - continue - } - } else { - #required named arg - if {$consumed == 0} { - if {$valname ni $valnames_received} { - #puts stderr "_get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES" - set msg "Bad number of values for %caller%. Not enough remaining values to assign to required arguments (fail on $valname)." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingrequiredvalue $valname ] -argspecs $argspecs]] $msg - } else { - incr validx -1 - set valname_multiple "" - incr nameidx - continue - } - } - } - #assert can_assign != 0, we have at least one value to assign to clause - - if {[llength $valtypelist] == 1} { - set clauseval $val - } else { - #clauseval must contain as many elements as the max length of -types! - #(empty-string/default for optional (?xxx?) clause members) - set clauseval $resultlist - #_get_dict_can_assign has only validated clause-length and literals match - #we assign and leave further validation for main validation loop. - incr validx -1 - incr validx $consumed - if {$validx > [llength $values]-1} { - error "get_dict unreachable" - set msg "Bad number of values for %caller%. Received [llength $clauseval] values for clause '$valname', but requires up to [llength $valtypelist] values." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength [llength $valname] ] -argspecs $argspecs]] $msg - } - - #for {set i 0} {$i < $consumed} {incr i} { - # incr validx - # if {$validx > [llength $values]-1} { - # set msg "Bad number of values for %caller%. Received [llength $clauseval] values for clause '$valname', but requires up to [llength $valtypelist] values." - # return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength [llength $valname] ] -argspecs $argspecs]] $msg - # } - # #lappend clauseval [lindex $values $validx] - #} - } - - if {[tcl::dict::get $argstate $valname -multiple]} { - #if {[tcl::dict::exists $VAL_DEFAULTS $valname]} { - # #current stored val equals defined default - don't include default in the list we build up - # tcl::dict::set values_dict $valname [list $clauseval] ;#important to treat first element as a list - #} else { - # tcl::dict::lappend values_dict $valname $clauseval - #} - if {$valname in $valnames_received} { - tcl::dict::lappend values_dict $valname $clauseval - } else { - tcl::dict::set values_dict $valname [list $clauseval] - } - set valname_multiple $valname - } else { - tcl::dict::set values_dict $valname $clauseval - set valname_multiple "" - incr nameidx - } - lappend valnames_received $valname - } else { - if {$valname_multiple ne ""} { - set valtypelist [tcl::dict::get $argstate $valname_multiple -type] - if {[llength $valname_multiple] == 1} { - set clauseval $val - } else { - set clauseval [list] - incr validx -1 - for {set i 0} {$i < [llength $valtypelist]} {incr i} { - incr validx - if {$validx > [llength $values]-1} { - set msg "Bad number of values for %caller%. Received [llength $clauseval] values for clause '$valname_multiple', but requires [llength $valtypelist] values." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength [llength $valtypelist] ] -argspecs $argspecs]] $msg - } - lappend clauseval [lindex $values $validx] - } - } - tcl::dict::lappend values_dict $valname_multiple $clauseval - #name already seen - but must add to valnames_received anyway (as with opts and leaders) - lappend valnames_received $valname_multiple - } else { - if {$VAL_UNNAMED} { - tcl::dict::set values_dict $positionalidx $val - tcl::dict::set argstate $positionalidx $VALSPEC_DEFAULTS - tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS - lappend valnames_received $positionalidx - } else { - set msg "Bad number of values for %caller%. Received more values than can be assigned to argument names. (set '@values -unnamed true' to allow unnamed values)" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list toomanyarguments [llength $values] index $positionalidx] -argspecs $argspecs]] $msg - } - } - } - set positionalidx [expr {$start_position + $validx + 1}] - } - #----------------------------------------------------- - #satisfy test parse_withdef_values_no_phantom_default - foreach vname [dict keys $values_dict] { - if {[string is integer -strict $vname]} { - #ignore vname that is a positionalidx - #review - always trailing - could break? - continue - } - if {$vname ni $valnames_received && ![dict exists $VAL_DEFAULTS $vname]} { - #remove the name with empty-string default we used to establish fixed order of names - #The 'values' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default. - dict unset values_dict $vname - } - } - #----------------------------------------------------- - - if {$leadermax == -1} { - #only check min - if {$num_leaders < $leadermin} { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected at least $leadermin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - } - } else { - if {$num_leaders < $leadermin || $num_leaders > $leadermax} { - if {$leadermin == $leadermax} { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected exactly $leadermin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - } else { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - } - } - } - - if {$valmax == -1} { - #only check min - if {$num_values < $valmin} { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $valmin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg - } - } else { - if {$num_values < $valmin || $num_values > $valmax} { - if {$valmin == $valmax} { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $valmin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg - } else { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $valmin and $valmax inclusive" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg - } - } - } - - #assertion - opts keys are full-length option names if -any|-arbitrary was false or if the supplied option as a shortname matched one of our defined options - - - #opts explicitly marked as -optional 0 must be present - regardless of -any|-arbitrary (which allows us to ignore additional opts to pass on to next call) - #however - if -any|-arbitrary 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 SHOULD? 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 - - #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? - #example timing difference: - #struct::set difference {x} {a b} - #normal interp 0.18 u2 vs safe interp 9.4us - #if {[llength [set missing [struct::set difference $OPT_REQUIRED $flagsreceived]]]} { - # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" - #} - #if {[llength [set missing [struct::set difference $VAL_REQUIRED $valnames_received]]]} { - # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" - #} - #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us - if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { - set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadermissing $missing received $leadernames_received] -argspecs $argspecs]] $msg - #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - set api_opt_required [lmap v $OPT_REQUIRED {lindex [split $v |] end}] - if {[llength [set missing [punklib_ldiff $api_opt_required $flagsreceived]]]} { - set full_missing [dict get $lookup_optset $missing] - set msg "Required option missing for %caller%. missing flags: '$full_missing' are marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list optionmissing $full_missing received $flagsreceived] -argspecs $argspecs]] $msg - #arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs - } - if {[llength [set missing [punklib_ldiff $VAL_REQUIRED $valnames_received]]]} { - set msg "Required value missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list valuemissing $missing received $valnames_received] -argspecs $argspecs]] $msg - #arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - - #--------------------------------------------------------------------------------------------- - #maintain order of opts $opts values $values as caller may use lassign. - set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] - if {[llength $receivednames]} { - #flat zip of names with overall posn, including opts - #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] - set i -1 - set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] - } else { - set received_posns [list] - } - #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) - #(e.g using 'dict exists $received -flag') - # - but it can have duplicate keys when args/opts have -multiple 1 - #It is actually a list of paired elements - #--------------------------------------------------------------------------------------------- - - - #todo - truncate/summarize values in error messages - - #todo - allow defaults outside of choices/ranges - - #check types,ranges,choices - set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] - #set combined_defaults [tcl::dict::merge $VAL_DEFAULTS $OPT_DEFAULTS] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash - #puts "---opts_and_values:$opts_and_values" - #puts "---argstate:$argstate" - tcl::dict::for {argname v} $opts_and_values { - if {[string match -* $argname]} { - #get full option name such as -fg|-foreground from non-alias name such as -foreground - #if "@opts -any|-arbitrary true" - we may have an option that wasn't defined - if {[dict exists $lookup_optset $argname]} { - set argname [dict get $lookup_optset $argname] - } - } - set thisarg [tcl::dict::get $argstate $argname] - #set thisarg_keys [tcl::dict::keys $thisarg] - set thisarg_checks [tcl::dict::get $arg_checks $argname] - set is_multiple [tcl::dict::get $thisarg -multiple] - set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] - set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] - set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] - set has_default [tcl::dict::exists $thisarg -default] - if {$has_default} { - set defaultval [tcl::dict::get $thisarg -default] - } - set typelist [tcl::dict::get $thisarg -type] - set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] - set regexprepass [tcl::dict::get $thisarg -regexprepass] - set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 - set validationtransform [tcl::dict::get $thisarg -validationtransform] - - - if {$is_multiple} { - set vlist $v - } else { - set vlist [list $v] - } - set vlist_original $vlist ;#retain for possible final strip_ansi - - #review - validationtransform - if {$is_validate_ansistripped} { - #validate_ansistripped 1 - package require punk::ansi - set vlist_check [list] - foreach e $vlist { - lappend vlist_check [punk::ansi::ansistrip $e] - } - } else { - #validate_ansistripped 0 - set vlist_check $vlist - } - - switch -- [Dict_getdef $thisarg -ARGTYPE unknown] { - leader { - set dname leaders_dict - set argclass "Leading argument" - } - option { - set dname opts - set argclass Option - } - value { - set dname values_dict - set argclass "Trailing argument" - } - default { - set dname "_unknown_" ;#NA - set argclass "Unknown argument" - } - } - #reduce our validation requirements by removing values which match defaultval or match -choices - #(could be -multiple with -choicerestricted 0 where some selections match and others don't) - if {$argname in $receivednames && $has_choices} { - #-choices must also work with -multiple - #todo -choicelabels - set choiceprefix [tcl::dict::get $thisarg -choiceprefix] - set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] - set choiceprefixreservelist [Dict_getdef $thisarg -choiceprefixreservelist {}] - set choicerestricted [tcl::dict::get $thisarg -choicerestricted] - set choicemultiple [tcl::dict::get $thisarg -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set nocase [tcl::dict::get $thisarg -nocase] - set choices [Dict_getdef $thisarg -choices {}] - set choicegroups [Dict_getdef $thisarg -choicegroups {}] - set allchoices $choices - if {[dict size $choicegroups]} { - dict for {groupname groupmembers} $choicegroups { - lappend allchoices {*}$groupmembers - } - } - #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups - #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes - - - set idx 0 ;# - #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes - #assert llength $vlist == llength [dict get $dname $argname] - # (unless there was a default and the option wasn't specified) - set vlist_validate [list] - set vlist_check_validate [list] - foreach e $vlist e_check $vlist_check { - set allchoices_in_list 0 - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - #vlist and vlist_check can be list of lists if -multiple and -choicemultiple - #each e represents 0 or more choice selections - set c_list $e - set c_check_list $e_check - #todo? check if entire list matches default? - } else { - #only one choice at a time - ensure single entry in c_list c_check_list - set c_list [list $e] - set c_check_list [list $e_check] - } - - - #----------------------------------- - #fast fail on the wrong number of choices - if {[llength $c_list] < $choicemultiple_min} { - set msg "$argclass $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { - set msg "$argclass $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - #----------------------------------- - - set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list - foreach c $c_list c_check $c_check_list { - if {$nocase} { - set casemsg " (case insensitive)" - set choices_test [tcl::string::tolower $allchoices] - #Don't lcase the denylist - even in nocase mode! - #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] - set v_test [tcl::string::tolower $c_check] - } else { - set casemsg " (case sensitive)" - set v_test $c_check - set choices_test $allchoices - } - set choice_in_list 0 - set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? - if {!$matches_default} { - if {$choiceprefix} { - #can we handle empty string as a choice? It should just work - REVIEW/test - set choice_exact_match 0 - if {$c_check in $allchoices} { - #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing - set chosen $c_check - set choice_in_list 1 - set choice_exact_match 1 - } elseif {$v_test in $choices_test} { - #assert - if we're here, nocase must be true - #we know choice is present as full-length match except for case - #now we want to select the case from the choice list - not the supplied value - #we don't set choice_exact_match - because we will need to override the optimistic existing val below - #review - foreach avail [lsort -unique $allchoices] { - if {[string match -nocase $c $avail]} { - set chosen $avail - } - } - #assert chosen will always get set - set choice_in_list 1 - } else { - #puts ">>>> choiceprefixreservelist: $choiceprefixreservelist" - #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. - #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. - #in this block we can treat empty result from prefix match as a non-match - if {$nocase} { - #nocase implies that our entered value doesn't have to match case of choices - - #but we would still like to select the best match if there are case-dups. - #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete - # selecting Del will find Delete, del will match delete (and raise error) - # but DEL will also match delete rather than Delete - so again an error is raised. - #This is counterintuitive with -nocase - #This is probably such an edge case that best served with documentation as a feature-not-bug - #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? - #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. - - set bestmatch [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check] - if {$bestmatch eq "" || $bestmatch in $choiceprefixreservelist} { - set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $choices_test] {*}$choiceprefixreservelist] $v_test] - #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing - set chosen [lsearch -inline -nocase $allchoices $chosen] - set choice_in_list [expr {$chosen ne ""}] - } else { - set chosen $bestmatch - set choice_in_list 1 - } - } else { - set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check] - if {$chosen eq "" || $chosen in $choiceprefixreservelist} { - set choice_in_list 0 - } else { - set choice_in_list 1 - } - } - #override choice_in_list if in deny list - #don't allow prefixing for elements from -choiceprefixdenylist - #we still use all elements to calculate the prefixes though - #review - case difference edge cases in choiceprefixdenylist !todo - if {$chosen in $choiceprefixdenylist} { - set choice_in_list 0 - set chosen "" - } - } - - #override the optimistic existing val - if {$choice_in_list && !$choice_exact_match} { - if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { - if {$is_multiple} { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $idx $chosen - tcl::dict::set $dname $argname $existing - } else { - tcl::dict::set $dname $argname $chosen - } - } else { - if {$is_multiple} { - set existing_all [tcl::dict::get [set $dname] $argname] - lset existing_all $idx $choice_idx $chosen - tcl::dict::set $dname $argname $existing_all - } else { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $choice_idx $chosen - tcl::dict::set $dname $argname $existing - } - } - } - } else { - #value as stored in $dname is ok - set choice_in_list [expr {$v_test in $choices_test}] - } - } - - if {!$choice_in_list && !$matches_default} { - if {!$choicerestricted} { - #if {$is_multiple} { - # set existing [tcl::dict::get [set $dname] $argname] - # lset existing $idx $v_test - # tcl::dict::set $dname $argname $existing - #} else { - # tcl::dict::set $dname $argname $v_test - #} - lappend vlist_validate $c - lappend vlist_check_validate $c_check - } else { - #unhappy path - if {$choiceprefix} { - set prefixmsg " (or a unique prefix of a value)" - } else { - set prefixmsg "" - } - #review: $c vs $c_check for -badval? - set msg "$argclass '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname - } - } - incr choice_idx - } - - incr idx - } - #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation - #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - - #todo - don't add to validation lists if not in receivednames - if {$argname ni $receivednames} { - set vlist [list] - set vlist_check_validate [list] - } else { - if {[llength $vlist] && $has_default} { - set vlist_validate [list] - set vlist_check_validate [list] - foreach c $vlist c_check $vlist_check { - #for -choicemultiple with default that could be a list use 'ni' ?? review - if {$c_check ne $defaultval} { - lappend vlist_validate $c - lappend vlist_check_validate $c - } - } - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - } - - #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups - #assert: our vlist & vlist_check lists have been reduced to remove those - if {[llength $vlist] && !$is_allow_ansi} { - #allow_ansi 0 - package require punk::ansi - #do not run ta::detect on a list - foreach e $vlist { - if {[punk::ansi::ta::detect $e]} { - set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - #puts "argname:$argname v:$v is_default:$is_default" - #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. - #arguments that are at their default are not subject to type and other checks - - #don't validate defaults or choices that matched - #puts "---> opts_and_values: $opts_and_values" - #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" - #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} - - #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups - #assert [llength $vlist] == [llength $vlist_check] - set type [lindex $typelist 0] - if {[llength $vlist]} { - - switch -- $type { - literal { - foreach e $vlist { - if {$e ne $argname} { - set msg "$argclass '$argname' for %caller% requires literal value '$argname'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - } - } - } - any {} - list { - foreach e_check $vlist_check { - if {![tcl::string::is list -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[llength $e_check] < $checkval} { - set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[llength $e_check] > $checkval} { - set msg "$argclass '$argname for %caller% requires list with -maxsize $checkval. Received len:[llength $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - } - indexexpression { - foreach e_check $vlist_check { - if {[catch {lindex {} $e_check}]} { - set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - string - ansistring - globstring { - #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string - #we possibly don't want to always have to regex on things that don't pass the other more basic checks - # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) - # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) - # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead - # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function - # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) - # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail - - #todo? - way to validate both unstripped and stripped? - set pass_quick_list_e [list] - set pass_quick_list_e_check [list] - set remaining_e $vlist - set remaining_e_check $vlist_check - #review - order of -regexprepass and -regexprefail in original rawargs significant? - #for now -regexprepass always takes precedence - if {$regexprepass ne ""} { - foreach e $vlist e_check $vlist_check { - if {[regexp $regexprepass $e]} { - lappend pass_quick_list_e $e - lappend pass_quick_list_e_check $e_check - } - } - set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] - set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] - } - if {$regexprefail ne ""} { - foreach e $remaining_e e_check $remaining_e_check { - #puts "----> checking $e vs regex $regexprefail" - if {[regexp $regexprefail $e]} { - if {[tcl::dict::exists $thisarg -regexprefailmsg]} { - #review - %caller% ?? - set msg [tcl::dict::get $thisarg -regexprefailmsg] - } else { - set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" - } - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - switch -- $type { - ansistring { - #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi - #.. so we need to look at the original values in $vlist not $vlist_check - - #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? - #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? - package require punk::ansi - foreach e $remaining_e { - if {![punk::ansi::ta::detect $e]} { - set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - globstring { - foreach e $remaining_e { - if {![regexp {[*?\[\]]} $e]} { - set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - - if {[tcl::dict::size $thisarg_checks]} { - foreach e_check $remaining_e_check { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[tcl::string::length $e_check] < $checkval} { - set msg "$argclass '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::string::length $e_check] > $checkval} { - set msg "$argclass '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - } - number { - #review - consider effects of Nan and Inf - #NaN can be considered as 'technically' a number (or at least a special numeric value) - lassign {} low high ;#set both empty - set has_range 0 - if {[tcl::dict::exists $thisarg -range]} { - lassign [tcl::dict::get $thisarg -range] low high - if {"$low$high" ne ""} { - set has_range 1 - } - } - foreach e $vlist e_check $vlist_check { - if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} { - set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - if {$has_range} { - if {[::tcl::mathfunc::isnan $e]} { - set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - if {$low eq ""} { - if {$e_check > $high} { - set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } elseif {$high eq ""} { - if {$e_check < $low} { - set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } else { - if {$e_check < $low || $e_check > $high} { - set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - int { - #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive - if {[tcl::dict::exists $thisarg -range]} { - lassign [tcl::dict::get $thisarg -range] low high - if {"$low$high" ne ""} { - if {$low eq ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - #lowside unspecified - check only high - if {$e_check > $high} { - set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } elseif {$high eq ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - #highside unspecified - check only low - if {$e_check < $low} { - set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } else { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - #high and low specified - if {$e_check < $low || $e_check > $high} { - set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } else { - foreach e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - double { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is double -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type double. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - if {[tcl::dict::size $thisarg_checks]} { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -range { - #todo - small-value double comparisons with error-margin? review - #todo - empty string for low or high - lassign $checkval low high - if {$e_check < $low || $e_check > $high} { - set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - bool { - foreach e_check $vlist_check { - if {![tcl::string::is boolean -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - dict { - foreach e_check $vlist_check { - if {[llength $e_check] %2 != 0} { - set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[tcl::dict::size $e_check] < $checkval} { - set msg "$argclass '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::dict::size $e_check] > $checkval} { - set msg "$argclass '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - } - alnum - - alpha - - ascii - - control - - digit - - graph - - lower - - print - - punct - - space - - upper - - wordchar - - xdigit { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is $type -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - file - - directory - - existingfile - - existingdirectory { - foreach e $vlist e_check $vlist_check { - #//review - we may need '?' char on windows - if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { - #what about special file names e.g on windows NUL ? - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - if {$type eq "existingfile"} { - foreach e $vlist e_check $vlist_check { - if {![file exists $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } elseif {$type eq "existingdirectory"} { - foreach e $vlist e_check $vlist_check { - if {![file isdirectory $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } - } - char { - #review - char vs unicode codepoint vs grapheme? - foreach e $vlist e_check $vlist_check { - if {[tcl::string::length $e_check] != 1} { - set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } - } - - } - - if {$is_strip_ansi} { - set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach - if {[tcl::dict::get $thisarg -multiple]} { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict $argname $stripped_list - } - option { - tcl::dict::set opts $argname $stripped_list - } - value { - tcl::dict::set values_dict $argname $stripped_list - } - } - } else { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict [lindex $stripped_list 0] - } - option { - tcl::dict::set opts $argname [lindex $stripped_list 0] - } - value { - tcl::dict::set values_dict [lindex $stripped_list 0] - } - } - } - } - } - - - - return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived multis $multisreceived] - } - - - proc forms {id} { - set spec [get_spec $id] - if {[dict size $spec]} { - return [dict get $spec form_names] - } else { - return [list] - } - } - lappend PUNKARGS [list { - @id -id ::punk::args::synopsis - @cmd -name punk::args::synopsis -help\ - "Return synopsis for each form of a command id - on separate lines. - If -form is given, supply only - the synopsis for that form. - " - @opts - -form -type string -default * - -return -type string -default full -choices {full summary dict} - @values -min 1 -max -1 - cmditem -multiple 1 -optional 0 - }] - proc synopsis {args} { - set argd [punk::args::parse $args withid ::punk::args::synopsis] - - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - if {$has_punkansi} { - set I [punk::ansi::a+ italic] - set RST [punk::ansi::a] - } else { - set I "" - set RST "" - } - - ##set form * - ##if {[lindex $args 0] eq "-form"} { - ## set arglist [lrange $args 2 end] - ## set form [lindex $args 1] - ##} else { - ## set arglist $args - ##} - ##if {[llength $arglist] == 0} { - ## error "punk::args::synopsis expected command id possibly with trailing subcommands/args" - ##} - ##set id [lindex $arglist 0] - ##set cmdargs [lrange $arglist 1 end] - - lassign [dict values $argd] leaders opts values - set form [dict get $opts -form] - set opt_return [dict get $opts -return] - set cmditems [dict get $values cmditem] - set id [lindex $cmditems 0] - set cmdargs [lrange $cmditems 1 end] - - - set spec [get_spec $id] - if {$spec eq ""} { - return - } - set form_names [dict get $spec form_names] - if {$form ne "*"} { - if {[string is integer -strict $form]} { - set f [lindex $form_names $form] - if {$f ne ""} { - set form_names [list $f] - } else { - set form_names [list] - } - } else { - if {$form in $form_names} { - set form_names [list $form] - } else { - set form_names [list] - } - } - } - - set SYND [dict create] - set syn "" - #todo - -multiple etc - foreach f $form_names { - set SYNLIST [list] - dict set SYND $f [list] - append syn "$id" - set forminfo [dict get $spec FORMS $f] - foreach argname [dict get $forminfo LEADER_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set ARGD [dict create argname $argname class leader] - if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - set display [lindex [dict get $arginfo -choices] 0] - } elseif {[dict get $arginfo -type] eq "literal"} { - set display $argname - } else { - set display $I$argname$RST - } - if {[dict get $arginfo -optional]} { - append syn " ?$display?" - } else { - append syn " $display" - } - dict set ARGD type [dict get $arginfo -type] - dict set ARGD optional [dict get $arginfo -optional] - dict set ARGD display $display - dict lappend SYND $f $ARGD - } - foreach argname [dict get $forminfo OPT_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set ARGD [dict create argname $argname class option] - set tp [dict get $arginfo -type] - if {[dict get $arginfo -optional]} { - if {[dict get $arginfo -multiple]} { - if {$tp eq "none"} { - set display "?$argname?..." - } else { - set display "?$argname <$tp>?..." - } - } else { - if {$tp eq "none"} { - set display "?$argname?" - } else { - set display "?$argname <$tp>?" - } - } - } else { - if {[dict get $arginfo -multiple]} { - if {$tp eq "none"} { - set display "$argname ?$argname...?" - } else { - set display "$argname <$tp> ?$argname <$tp>?..." - } - } else { - if {$tp eq "none"} { - set display $argname - } else { - set display "$argname <$tp>" - } - } - } - append syn " $display" - dict set ARGD type [dict get $arginfo -type] - dict set ARGD optional [dict get $arginfo -optional] - dict set ARGD display $display - dict lappend SYND $f $ARGD - } - foreach argname [dict get $forminfo VAL_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set typelist [dict get $arginfo -type] - if {[llength $typelist] == 1} { - set tp [lindex $typelist 0] - if {$tp eq "literal"} { - set clause [lindex $argname end] - } elseif {[string match literal(*) $tp]} { - set match [string range $tp 8 end-1] - set clause $match - } else { - set clause $I$argname$RST - } - } else { - set n [expr {[llength $typelist]-1}] - set name_tail [lrange $argname end-$n end];#if there are enough tail words in the argname to match -types - set clause "" - foreach typespec $typelist elementname $name_tail { - #elementname will commonly be empty - if {[string match {\?*\?} $typespec]} { - set tp [string range $typespec 1 end-1] - set member_optional 1 - } else { - set tp $typespec - set member_optional 0 - } - if {$tp eq "literal"} { - set c $elementname - } elseif {[string match literal(*) $tp]} { - set match [string range $tp 8 end-1] - set c $match - } else { - set c $I$tp$RST - } - if {$member_optional} { - append clause " " "(?$c?)" - } else { - append clause " " $c - } - } - set clause [string trimleft $clause] - } - - set ARGD [dict create argname $argname class value] - if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} { - if {[dict get $arginfo -multiple]} { - #set display "?$I$argname$RST?..." - set display "?$clause?..." - } else { - set display "?$clause?" - #if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - # set display "?[lindex [dict get $arginfo -choices] 0]?" - #} elseif {[dict get $arginfo -type] eq "literal"} { - # set display "?$argname?" - #} else { - # set display "?$I$argname$RST?" - #} - } - } else { - if {[dict get $arginfo -multiple]} { - #set display "$I$argname$RST ?$I$argname$RST?..." - set display "$clause ?$clause?..." - } else { - set display $clause - #if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - # set display "[lindex [dict get $arginfo -choices] 0]" - #} elseif {[dict get $arginfo -type] eq "literal"} { - # set display $argname - #} else { - # set display "$I$argname$RST" - #} - } - } - append syn " $display" - dict set ARGD type [dict get $arginfo -type] - dict set ARGD optional [dict get $arginfo -optional] - dict set ARGD display $display - dict lappend SYND $f $ARGD - } - append syn \n - } - switch -- $opt_return { - full { - return [string trim $syn \n] - } - summary { - set summary "" - dict for {form arglist} $SYND { - append summary $id - set class_state leader - set option_count 0 - set value_count 0 - foreach ainfo $arglist { - switch -- [dict get $ainfo class] { - leader { - append summary " [dict get $ainfo display]" - } - option { - incr option_count - } - value { - incr value_count - if {$class_state ne "value"} { - if {$option_count > 0} { - append summary " ?options ($option_count defined)?" - } - set class_state value - } - append summary " [dict get $ainfo display]" - } - } - } - if {$value_count == 0 && $option_count > 0} { - append summary " ?options ($option_count defined)?" - } - append summary \n - } - set summary [string trim $summary \n] - return $summary - } - dict { - return $SYND - } - } - } - - - lappend PUNKARGS [list { - @id -id ::punk::args::synopsis_summary - @cmd -name punk::args::synopsis_summary -help\ - "Reduce the width of a synopsis string - by coalescing options to ?options?... - synopsis string may be arbitrarily marked - up with ANSI codes." - @opts - @values -min 1 -max -1 - synopsis -multiple 0 -optional 0 - }] - proc synopsis_summary {args} { - set argd [punk::args::parse $args withid ::punk::args::synopsis_summary] - set synopsis [dict get $argd values synopsis] - set summary "" - foreach sline [split $synopsis \n] { - set sline [regsub -all {\s+} $sline " "] ;#normalize to single spacing only - review - set in_opt 0 - set line_out "" - set codestack [list] - set parts [punk::ansi::ta::split_codes_single $sline] - #basic - foreach {pt code} $parts { - set charlist [split $pt ""] - for {set i 0} {$i < [llength $charlist]} {incr i} { - set c [lindex $charlist $i] - - switch -- $c { - ? { - if {!$in_opt} { - set in_opt 1 - } else { - - } - } - " " { - if {!$in_opt} { - append line_out " " - } else { - set in_opt - } - } - default { - if {!$in_opt} { - append line_out $c - } - } - } - } - if {$code ne ""} { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set codestack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set codestack [list $code] - } elseif {[punk::ansi::codetype::is_sgr $code]} { - #basic simplification first - remove straight dupes - set dup_posns [lsearch -all -exact $codestack $code] ;#must be -exact because of square-bracket glob chars - set codestack [lremove $codestack {*}$dup_posns] - lappend codestack $code - } else { - #? ignore other ANSI codes? - } - } - } - if {[string match -* $plain_s] || [string match ?- $plain_s]} { - } - } - return $summary - } - - lappend PUNKARGS [list { - @id -id ::punk::args::TEST - @opts -optional 0 - -o1 -default 111 -help "opt 1 mandatory" - @opts -optional 1 - -o2 -default 222 -help "opt 2 optional" - @values -min 0 -max 1 - v -help\ - "v1 optional" - }] - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::lib { - variable PUNKARGS - tcl::namespace::export * - tcl::namespace::path [list [tcl::namespace::parent]] - #*** !doctools - #[subsection {Namespace punk::args::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 flatzip {l1 l2} { - concat {*}[lmap a $l1 b $l2 {list $a $b}] - } - - if {[info commands lseq] ne ""} { - #tcl 8.7+ lseq significantly faster, especially for larger ranges - #The internal rep can be an 'arithseries' with no string representation - proc zero_based_posns {count} { - if {$count < 1} {return} - lseq 0 $count-1 - } - } else { - proc zero_based_posns {count} { - if {$count < 1} {return} - lsearch -all [lrepeat $count 0] * - } - } - - #return list of single column-width marks - possibly with ansi - proc choiceinfo_marks {choice choiceinfodict} { - set marks [list] - if {[dict exists $choiceinfodict $choice]} { - set cinfo [dict get $choiceinfodict $choice] - foreach info $cinfo { - if {[lindex $info 0] eq "doctype"} { - switch -- [lindex $info 1] { - punkargs { - lappend marks [punk::ns::Cmark punkargs brightgreen] - } - ensemble { - lappend marks [punk::ns::Cmark ensemble brightyellow] - } - oo { - lappend marks [punk::ns::Cmark oo brightcyan] - } - ooc { - lappend marks [punk::ns::Cmark ooc cyan] - } - ooo { - lappend marks [punk::ns::Cmark ooo cyan] - } - native { - lappend marks [punk::ns::Cmark native] - } - unknown { - lappend marks [punk::ns::Cmark unknown brightred] - } - } - } - } - } - return $marks - } - - - #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 -1] in calling scope ${[lindex [set x] 0]} !} - lappend PUNKARGS [list { - @id -id ::punk::args::lib::tstr - @cmd -name punk::args::lib::tstr -help\ - "A rough equivalent of js template literals - - Substitutions: - \$\{$varName\} - \$\{[myCommand]\} - (when -allowcommands flag is given)" - -allowcommands -default 0 -type none -help\ - "If -allowcommands is present, placeholder can contain commands - e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" - -undent -default 1 -type boolean -help\ - "undent/dedent the template lines. - The longest common prefix of whitespace is removed" - -indent -default "" -type string -help\ - "String with which to indent the template - prior to substitution. - If -undent is enabled, that is performed - first, then the indent is applied." - -paramindents -default line -choices {none line position} -choicelabels { - line\ - " Use leading whitespace in - the line in which the - placeholder occurs." - position\ - " Use the position in - the line in which the - placeholder occurs." - none\ - " No indents applied to - subsequent placeholder value - lines. This will usually - result in text awkwardly - ragged unless the source code - has also been aligned with the - left margin or the value has - been manually padded." - } -help\ - "How indenting is done for subsequent lines in a - multi-line placeholder substitution value. - The 1st line or a single line value is always - placed at the placeholder. - paramindents are performed after the main - template has been indented/undented. - (indenting by position does not calculate - unicode double-wide or grapheme cluster widths) - " - #choicelabels indented by 1 char is clearer for -return string - and reasonable in table - -return -default string -choices {dict list string args}\ - -choicelabels { - dict\ - " Return a dict with keys - 'template', 'params' and - 'errors'" - string\ - " Return a single result - being the string with - placeholders substituted." - list\ - " Return a 2 element list. - The first is itself a list - of plaintext portions of the - template, split at each point - at which placeholders were - present. The second element - of the outer list is a list - of placeholder values if -eval - is 1, or a list of the raw - placeholder strings if -eval - is 0." - args\ - " Return a list where the first - element is a list of template - plaintext sections as per the - 'list' return mechanism, but the - placeholder items are individual - items in the returned list. - This can be useful when passing - the expanded result of a tstr - command to another function - which expects the placeholders - as individual arguments" - } - -eval -default 1 -type boolean -help\ - "Whether to evaluate the \$\{\} placeholders. - When -return is string, -eval should generally be set to 1. - For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. - contained variables in that case should be braced or whitespace separated, or the variable - name is likely to collide with surrounding text. - e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" - @values -min 0 -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 - e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} - - Escape sequences such as \\n and unicode escapes are processed within placeholders. - " - }] - - proc tstr {args} { - #Too hard to fully eat-our-own-dogfood from within punk::args package - # - we use punk::args within the unhappy path only - #set argd [punk::args::get_by_id ::punk::lib::tstr $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 opt_eval [dict get $argd opts -eval] - - set templatestring [lindex $args end] - set arglist [lrange $args 0 end-1] - set opts [dict create\ - -allowcommands 0\ - -undent 1\ - -indent ""\ - -paramindents line\ - -eval 1\ - -return string\ - ] - if {"-allowcommands" in $arglist} { - set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] - dict set opts -allowcommands 1 - } - if {[llength $arglist] % 2 != 0} { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr expected option/value pairs prior to last argument" - } - } - dict for {k v} $arglist { - set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] - switch -- $fullk { - -indent - -undent - -paramindents - -return - -eval { - dict set opts $fullk $v - } - default { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" - } - } - } - } - set opt_allowcommands [dict get $opts -allowcommands] - set opt_paramindents [dict get $opts -paramindents] - set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] - if {$test_paramindents ni {none line position}} { - error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." - } - set opt_paramindents $test_paramindents - set opt_return [dict get $opts -return] - set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] - if {$opt_return eq ""} { - } - set opt_eval [dict get $opts -eval] - - - set nocommands "-nocommands" - if {$opt_allowcommands == 1} { - set nocommands "" - } - - set opt_undent [dict get $opts -undent] - if {$opt_undent} { - set templatestring [punk::args::lib::undent $templatestring] - } - set opt_indent [dict get $opts -indent] - if {$opt_indent ne ""} { - set templatestring [punk::args::lib::indent $templatestring $opt_indent] - } - - #set parts [_tstr_split $templatestring] - if {[string first \$\{ $templatestring] < 0} { - set parts [list $templatestring] - } else { - set parts [_parse_tstr_parts $templatestring] - } - set textchunks [list] - #set expressions [list] - set params [list] - set idx 0 - set errors [dict create] - set lastline "" ;#todo - first line has placeholder? - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach {pt expression} $parts { - lappend textchunks $pt - incr idx ;#pt incr - - #ignore last expression - if {$idx == [llength $parts]} { - break - } - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - #lappend expressions $expression - #---------------------- - #REVIEW - JMN - #TODO - debug punk::args loading of @dynamic defs - #puts "-- $expression" - #---------------------- - #brk1 - literal newline not {\n} - set leader "" - if {[set brk1 [string first \n $expression]] >= 0} { - #undent left of paramstart only for lines of expression that arent on opening ${..} line - set tail [string range $expression $brk1+1 end] - set leader [string repeat " " [string length $lastline]] - set undentedtail [punk::args::lib::undentleader $tail $leader] - #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] - set expression "[string range $expression 0 $brk1]$undentedtail" - } - if {$opt_eval} { - if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { - lappend params [string cat \$\{ $expression \}] - dict set errors [expr {[llength $params]-1}] $result - } else { - set result [string map [list \n "\n$leader"] $result] - lappend params $result - } - #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] - } else { - #JJJ - #REVIEW - #lappend params [subst -nocommands -novariables $expression] - lappend params $expression - } - append lastline [lindex $params end] ;#for current expression's position calc - - incr idx ;#expression incr - } - - if {$opt_return eq "dict"} { - return [dict create template $textchunks params $params errors $errors] - } - if {[dict size $errors]} { - set einfo "" - dict for {i e} $errors { - append einfo "parameter $i error: $e" \n - } - #REVIEW!!! - #TODO - fix - #puts stderr "tstr errors:\n$einfo\n" - } - - switch -- $opt_return { - list { - return [list $textchunks $params] - } - args { - #see example in tstr_test_one - return [list $textchunks {*}$params] - } - string { - #todo - flag to disable indent-matching behaviour for multiline param? - set out "" - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach pt $textchunks param $params { - if {$opt_paramindents eq "none"} { - append out $pt $param - } else { - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - if {$opt_paramindents eq "line"} { - regexp {(\s*).*} $lastline _all lastindent - } else { - #position - #TODO - detect if there are grapheme clusters - #This regsub doesn't properly space unicode double-wide chars or clusters - set lastindent "[regsub -all {\S} $lastline " "] " - } - if {$lastindent ne ""} { - set paramlines [split $param \n] - if {[llength $paramlines] == 1} { - append out $pt $param - } else { - append out $pt [lindex $paramlines 0] - foreach nextline [lrange $paramlines 1 end] { - append out \n $lastindent $nextline - } - } - } else { - append out $pt $param - } - append lastline $param - } - } - return $out - } - } - } - #test single placeholder tstr args where single placeholder must be an int - proc tstr_test_one {args} { - set argd [punk::args::parse $args withdef { - @cmd -name ::punk::args::lib::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 -return args {Select * from table where id = \$\{$id\} and etc... ;}] - } - - @values -min 2 -max 2 - template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - - but the tstr call in the example 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} - }] - 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]] ""] - set result [string cat [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 dollar sign - 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]] - } - - #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. - proc indent {text {prefix " "}} { - set result [list] - foreach line [split $text \n] { - if {[string trim $line] eq ""} { - lappend result "" - } else { - lappend result $prefix[string trimright $line] - } - } - return [join $result \n] - } - #dedent? - proc undent {text} { - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - regexp {^([\t ]*)} $lcp _m lcp - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - - #hacky - proc undentleader {text leader} { - #leader usually whitespace - but doesn't have to be - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - lappend nonblank "${leader}!!" - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - #regexp {^([\t ]*)} $lcp _m lcp - #lcp can be shorter than leader - set lcp [string range $lcp 0 [string length $leader]-1] - - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - #A version of textutil::string::longestCommonPrefixList - proc longestCommonPrefix {items} { - if {[llength $items] <= 1} { - return [lindex $items 0] - } - set items [lsort $items[unset items]] - set min [lindex $items 0] - set max [lindex $items end] - #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) - #(sort order nothing to do with length - e.g min may be longer than max) - if {[string length $min] > [string length $max]} { - set temp $min - set min $max - set max $temp - } - set n [string length $min] - set prefix "" - set i -1 - while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { - append prefix $c - } - return $prefix - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] -} - -tcl::namespace::eval punk::args::argdocbase { - namespace export * - #use a? to test and create literal ansi here rather than relying on punk::ansi package presence - #e.g - #% a? bold - #- bold │SGR 1│sample│␛[1msample - #- ──────┼─────┼──────┼────────── - #- RESULT│ │sample│␛[1msample - proc B {} {return \x1b\[1m} ;#a+ bold - proc N {} {return \x1b\[22m} ;#a+ normal - proc I {} {return \x1b\[3m} ;#a+ italic - proc NI {} {return \x1b\[23m} ;#a+ noitalic - -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::package { - variable PUNKARGS - lappend PUNKARGS [list { - @dynamic - @id -id "::punk::args::package::standard_about" - @cmd -name "%pkg%::about" -help\ - "About %pkg% - ... - " - -package_about_namespace -type string -optional 0 -help\ - "Namespace containing the package about procedures - Must contain " - -return\ - -type string\ - -default table\ - -choices {string table tableobject}\ - -choicelabels { - string\ - "A basic text layout" - table\ - "layout in table borders - (requires package: textblock)" - tableobject\ - "textblock::class::table object instance" - }\ - -help\ - "Choose the return type of the 'about' information" - topic -optional 1\ - -nocase 1\ - -default {*}\ - -choices {Description License Version Contact *}\ - -choicerestricted 0\ - -choicelabels { - - }\ - -multiple 1\ - -help\ - "Topic to display. Omit or specify as * to see all. - If * is included with explicit topics, * represents - the remaining unmentioned topics." - }] - proc standard_about {args} { - set argd [punk::args::parse $args withid ::punk::args::package::standard_about] - lassign [dict values $argd] leaders OPTS values received - - set pkgns [dict get $OPTS -package_about_namespace] - if {[info commands ${pkgns}::package_name] eq ""} { - error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" - } - set pkgname [${pkgns}::package_name] - - set opt_return [dict get $OPTS -return] - set all_topics [${pkgns}::about_topics] - if {![dict exists $received topic]} { - set topics $all_topics - } else { - # * represents all remaining topics not explicitly mentioned. - set val_topics [dict get $values topic] ;#if -multiple is true, this is a list - set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] - set topics [list] - foreach t $val_topics { - if {$t eq "*"} { - foreach a $all_topics { - if {$a ni $explicit_topics} { - lappend topics $a - } - } - } else { - lappend topics $t - } - } - } - if {$opt_return ne "string"} { - package require textblock ;#table support - set is_table 1 - set title [string cat {[} $pkgname {]} ] - set t [textblock::class::table new -title $title] - $t configure -frametype double -minwidth [expr {[string length $title]+2}] - - } else { - set topiclens [lmap t $topics {string length $t}] - set widest_topic [tcl::mathfunc::max {*}$topiclens] - set is_table 0 - set about "$pkgname\n" - append about [string repeat - $widest_topic] \n - } - foreach topic $topics { - if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { - set topic_contents [::${pkgns}::get_topic_$topic] - } else { - set topic_contents "" - } - if {!$is_table} { - set content_lines [split $topic_contents \n] - append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n - foreach ln [lrange $content_lines 1 end] { - append about [format %-${widest_topic}s ""] " " $ln \n - } - } else { - $t add_row [list $topic $topic_contents] - } - } - - if {!$is_table} { - return $about - } else { - if {$opt_return eq "tableobject"} { - return $t - } - set result [$t print] - $t destroy - return $result - } - } - -} - -#usually we would directly call arg definitions near the defining proc, -# so that the proc could directly use the definition in its parsing. -# -#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. -#arguably it may be more processor-cache-efficient to do together like this anyway. - -#can't do this here? - as there is circular dependency with punk::lib -#tcl::namespace::eval punk::args { -# foreach deflist $PUNKARGS { -# punk::args::define {*}$deflist -# } -# set PUNKARGS "" -#} - -lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -tcl::namespace::eval punk::args::system { - #*** !doctools - #[subsection {Namespace punk::args::system}] - #[para] Internal functions that are not part of the API - - #dict get value with default wrapper for tcl 8.6 - if {[info commands ::tcl::dict::getdef] eq ""} { - proc Dict_getdef {dictValue args} { - set keys [lrange $args 0 end-1] - if {[tcl::dict::exists $dictValue {*}$keys]} { - return [tcl::dict::get $dictValue {*}$keys] - } else { - return [lindex $args end] - } - } - } else { - #we pay a minor perf penalty for the wrap - interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef - } - - #name to reflect maintenance - home is punk::lib::ldiff - proc punklib_ldiff {fromlist removeitems} { - if {[llength $removeitems] == 0} {return $fromlist} - set result {} - foreach item $fromlist { - if {$item ni $removeitems} { - lappend result $item - } - } - return $result - } - -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::args [tcl::namespace::eval punk::args { - tcl::namespace::path {::punk::args::lib ::punk::args::system} - variable pkg punk::args - variable version - set version 0.1.8 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.9.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.9.tm deleted file mode 100644 index e64f2d54..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.9.tm +++ /dev/null @@ -1,7959 +0,0 @@ -# -*- 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: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.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 punk::args 0.1.9 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.1.9] -#[copyright "2024"] -#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] -#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] -#[require punk::args] -#[keywords module proc args arguments parse] -#[description] -#[para]Utilities for parsing proc args - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). -#[para] overview of punk::args -#[subsection Concepts] -#[para]There are 2 main conventions for parsing a proc args list -#[list_begin enumerated] -#[enum] -#[para]leading option-value pairs and flags followed by a list of values (Tcl style) -#[enum] -#[para]leading list of values followed by option-value pairs and flags (Tk style) -#[list_end] -#[para]There are exceptions in both Tcl and Tk commands regarding this ordering -#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style -#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] -#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. -#[para] -#[para]The basic principle is that a call to punk::args::parse is made near the beginning of the proc with a cacheable argument defining the parameters e.g -#[example { -# proc dofilestuff {args} { -# lassign [dict values [punk::args::parse $args withdef { -# @cmd -help "do some stuff with files e.g dofilestuff " -# @opts -type string -# #comment lines ok -# -directory -default "" -# -translation -default binary -# #setting -type none indicates a flag that doesn't take a value (solo flag) -# -nocomplain -type none -# @values -min 1 -max -1 -# }]] leaders opts values -# -# puts "translation is [dict get $opts -translation]" -# foreach f [dict values $values] { -# puts "doing stuff with file: $f" -# } -# } -#}] -#[para]The lines beginning with @ are usually optional in most cases and can be used to set defaults and some extra controls -#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values -#[para]valid @ lines being with @cmd @leaders @opts @values -#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. -#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. -#[para]e.g the result from the punk::args::parse call above may be something like: -#[para] leaders {} opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} -#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments -#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments -#[para]This could also be implemented entirely using args - and the @leaders category of arguments -#[example { -# proc dofilestuff {category args} { -# lassign [dict values [punk::args::parse $args withdef { -# @id -id ::dofilestuff -# -directory -default "" -# -translation -default binary -# -nocomplain -type none -# @values -min 2 -max 2 -# fileA -type existingfile 1 -# fileB -type existingfile 1 -# }]] leaders opts values -# puts "$category fileA: [dict get $values fileA]" -# puts "$category fileB: [dict get $values fileB]" -# } -#}] -#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 -#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored -#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, -#[para] or an additional call could be made to punk::args e.g -#[example { -# punk::args::parse [list $category $another_leading_arg] withdef { -# category -choices {cat1 cat2 cat3} -# another_leading_arg -type boolean -# } -#}] - -#*** !doctools -#[subsection Notes] -#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. -#[para] -#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. -#For functions that are part of an API a package may be more suitable. -#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) -#[example { -# proc test_switch {args} { -# set opts [dict create\\ -# -return "object"\\ -# -frametype "heavy"\\ -# -show_edge 1\\ -# -show_seps 0\\ -# -x a\\ -# -y b\\ -# -z c\\ -# -1 1\\ -# -2 2\\ -# -3 3\\ -# ] -# foreach {k v} $args { -# switch -- $k { -# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { -# dict set opts $k $v -# } -# default { -# error "unrecognised option '$k'. Known options [dict keys $opts]" -# } -# } -# } -# return $opts -# } -#}] -#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. -#[para] -# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. -# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. -#[para]use punk::lib::show_jump_tables to verify that a jump table exists. -#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous -#[example { -# proc test_prefix {args} { -# set opts [dict create\ -# -return string\ -# -frametype \uFFEF\ -# -show_edge \uFFEF\ -# -show_seps \uFFEF\ -# -x a\ -# -y b\ -# -z c\ -# -1 1\ -# -2 2\ -# -3 3\ -# ] -# if {[llength $args]} { -# set knownflags [dict keys $opts] -# } -# foreach {k v} $args { -# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v -# } -# return $opts -# } -#}] -#[para]There are many alternative args parsing packages a few of which are listed here. -#[list_begin enumerated] -#[enum]argp (pure tcl) -#[enum]parse_args (c implementation) -#[enum]argparse (pure tcl *) -#[enum]cmdline (pure tcl) -#[enum]opt (pure tcl) distributed with Tcl but considered deprecated -#[enum]The tcllib set of TEPAM modules (pure tcl) -#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. -#[list_end] -#[para] (* c implementation planned/proposed) -#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. -#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences -#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. -#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. -#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. -#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. -#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -#All ensemble commands are slower in a safe interp as they aren't compiled the same way -#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 -#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. -#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) -#ensembles: array binary clock dict info namespace string -#possibly file too, although that is generally hidden/modified in a safe interp -#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc -#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::args -#[list_begin itemized] -package require Tcl 8.6- -#optional? punk::trie -#optional? punk::textblock -#*** !doctools -#[item] [package {Tcl 8.6-}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -tcl::namespace::eval punk::args::register { - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] cooperative namespace punk::args::register - #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded - #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. - #[list_begin definitions] - - #Although the actual punk::args::define calls are not too sluggish, there could be *many*. - #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, - #especially since a fair proportion may be for documentation purposes rather than parsing args. - - # -- --- --- --- --- --- --- --- - #cooperative with packages that define some punk args but do so lazily - #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first - variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective - if {![info exists ::punk::args::register::NAMESPACES]} { - set ::punk::args::register::NAMESPACES [list] - } - # -- --- --- --- --- --- --- --- - - variable loaded_packages - if {![info exists loaded_packages]} { - set loaded_packages [list] ;#fully loaded - } - variable loaded_info - if {![info exists loaded_info]} { - set loaded_info [dict create] ;#time - } - variable scanned_packages - if {![info exists scanned_packages]} { - set scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages - } - variable scanned_info ;#time and idcount - if {![info exists scanned_info]} { - set scanned_info [dict create] - } - #some packages, e.g punk::args::tclcore document other namespaces. - #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources - variable namespace_docpackages - if {![info exists namespace_docpackages]} { - set namespace_docpackages [dict create] - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::register ---}] -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args { - - - variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. - - tcl::namespace::export {[a-z]*} - variable rawdef_cache - if {![info exists rawdef_cache]} { - set rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} - } - variable id_cache_rawdef - if {![info exists id_cache_rawdef]} { - set id_cache_rawdef [tcl::dict::create] - } - variable id_cache_spec - if {![info exists id_cache_spec]} { - set id_cache_spec [tcl::dict::create] - } - - variable argdefcache_unresolved - if {![info exists argdefcache_unresolved]} { - set argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) - } - - variable argdata_cache - if {![info exists argdata_cache]} { - set argdata_cache [tcl::dict::create] - } - - variable id_counter - if {![info exists id_counter]} { - set id_counter 0 - } - - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] Core API functions for punk::args - #[list_begin definitions] - - #todo - some sort of punk::args::cherrypick operation to get spec from an existing set - #todo - doctools output from definition - - - - - #todo? -synonym/alias ? (applies to opts only not values) - #e.g -background -aliases {-bg} -default White - #review - how to make work with trie prefix - #e.g - # -corner -aliases {-corners} - # -centre -aliases {-center -middle} - #We mightn't want the prefix to be longer just because of an alias - #we should get -co -ce and -m from the above as abbreviations - - set map [list %G% \x1b\[32m %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] - - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::define - #todo @preamble -help "move large block outside of table?" - @cmd -name punk::args::define -help\ - "Accepts a line-based definition of command arguments. - The definition can be supplied as a single text block or multiple as described - in the help information for 'text' below. - - Returns an id which is a key to the stored definition. - The id is taken from the supplied definition's @id -id line, or is an - automatically created id of the form 'autoid_'. - - At the time define is called - just the raw text arguments are stored for the id. - When the id is first used, for example with 'punk::args::parse $args withid $id', - the raw definition is parsed into a stored specifications dictionary. - - This specifications dictionary is structured for (optional) use within commands to - parse and validate the arguments - and is also used when retrieving definitions - (or parts thereof) for re-use. - - This can be used purely for documentation or called within a function to parse a mix - of leading values, switches/flags and trailing values. - - The overhead is favourably comparable with other argument processors - but none are - as fast as minimal code with a switch statement. For toplevel commands where a few - 10s of microseconds is immaterial, the validation and automated error formatting in - a table can be well worthwhile. For inner procs requiring utmost speed, the call can - be made only on the unhappy path when basic processing determines a mismatch - or it - can be left entirely as documentation for interactive use with: i ... - and for synopsis generation with: s ... - - The definition should usually contain an initial line of the form: @id -id ::somecmd - - Blank lines are ignored at the top level, ie if they are not part of another structure. - Similarly - lines at the top level beginning with the # character are ignored. - All other toplevel lines must consist of a leading word followed by paired arguments. - The arguments can be spread over multiple lines and contain lines of near-arbitrary - text if they are properly braced or double quoted and Tcl escaping for inner quotes - or unbalanced braces is maintained. - The line continuation character - (\\ at the end of the line) can be used to continue the set of arguments for - a leading word. - Leading words beginning with the @ character are directives controlling argument - parsing, defaults for subsequent arguments, and help display. - directives include: - %B%@id%N% ?opt val...? - directive-options: -id - %B%@cmd%N% ?opt val...? - directive-options: -name -help - %B%@leaders%N% ?opt val...? - (used for leading args that come before switches/opts) - directive-options: -min -max -unnamed - (also accepts options as defaults for subsequent arguments) - %B%@opts%N% ?opt val...? - directive-options: -any|-arbitrary - %B%@values%N% ?opt val...? - (used for trailing args that come after switches/opts) - directive-options: -min -max -unnamed - (also accepts options as defaults for subsequent arguments) - %B%@form%N% ?opt val...? - (used for commands with multiple forms) - directive-options: -form -synopsis - The -synopsis value allows overriding the auto-calculated - synopsis. - %B%@formdisplay%N% ?opt val...? - directive-options: -header (text for header row of table) - -body (override autogenerated arg info for form) - %B%@doc%N% ?opt val...? - directive-options: -name -url - %B%@seealso%N% ?opt val...? - directive-options: -name -url (for footer - unimplemented) - - Some other options normally present on custom arguments are available - to use with the @leaders @opts @values directives to set defaults - for subsequent lines that represent your custom arguments. - These 3 directives should occur in exactly this order - but can be - repeated with custom argument lines interspersed. - - An @id line can only appear once and should be the first item. - For the commandline usage to be displayed either on parsing error - or using the i .. function - an @id with -id is needed. - - All directives can be omitted, in which case every line represents - a custom leader, value or option. - All will be leaders by default if no options defined. - If options are defined (by naming with leading dash, or explicitly - specifying @opts) then the definitions prior to the options will be - categorised as leaders, and those following the options will be - categorised as values. - - Custom arguments are defined by using any word at the start of a - line that doesn't begin with @ or - - (except that adding an additionl @ escapes this restriction so - that @@somearg becomes an argument named @somearg) - - custom leading args, switches/options (names starting with -) - and trailing values also take spec-options: - - -type - defaults to string. If no other restrictions - are specified, choosing string does the least validation. - recognised types: - int - integer - number - list - indexexpression - dict - double - float - bool - boolean - char - file - directory - ansistring - globstring - (any of the types accepted by 'string is') - - The above all perform some validation checks - - string - (also any of the 'string is' types such as - xdigit, graph, punct, lower etc) - any - (unvalidated - accepts anything) - none - (used for switches only. Indicates this is - a 'solo' flag ie accepts no value) - - literal() - (exact match for string) - literalprefix() - (prefix match for string, other literal and literalprefix - entries specified as alternates using | are used in the - calculation) - - Note that types can be combined with | to indicate an 'or' - operation - e.g char|int - e.g literal(xxx)|literal(yyy) - e.g literalprefix(text)|literalprefix(binary) - (when all in the pipe-delimited type-alternates set are - literal or literalprefix - this is similar to the -choices - option) - - - and more.. (todo - document here) - If a typenamelist is supplied and has length > 1 - then -typeranges must be used instead of -range - The number of elements in -typeranges must match - the number of elements specified in -type. - - -typesynopsis - Must be same length as value in -type - This provides and override for synopsis display of types. - Any desired italicization must be applied manually to the - value. - - -optional - (defaults to true for flags/switches false otherwise) - For non flag/switch arguments - all arguments with - -optional true must sit consecutively within their group. - ie all optional leader arguments must be together, and all - optional value arguments must be together. Furthermore, - specifying both optional leaders and optional values will - often lead to ambiguous parsing results. Currently, all - optional non-flg/switch arguments should be either at the - trailing end of leaders or the trailing end of values. - Further unambiguous arrangements of optional args may be - made in future - but are currently considered 'unsupported' - -default - -multiple (for leaders & values defines whether - subsequent received values are stored against the same - argument name - only applies to final leader OR final value) - (for options/flags this allows the opt-val pair or solo - flag to appear multiple times - not necessarily contiguously) - -choices {} - A list of allowable values for an argument. - The -default value doesn't have to be in the list. - If a -type is specified - it doesn't apply to choice members. - It will only be used for validation if the -choicerestricted - option is set to false. If all choices are specified in values - within the -choicegroups dict, it is not necessary to specify them - in the -choices list. It is effectively a simpler form of - specifying choices when no grouping is required. It is fine to - use both -choices and -choicegroups e.g specifying all in -choices - and then including only some that need grouping in -choicegroups. - -choicelabels {} - keys are the values/argument names from -choices (or equivalently - members of value entries from the -choicegroups dict) - The values in the choicelabels dict are text values, possibly - containing newlines, that are displayed below each choice. - This is commonly a very basic summary of the choice. In the - case of a subcommand it may be a usage synopsis for further - arguments. - -choicerestricted - Whether values not specified in -choices or -choicegroups are - allowed. Defaults to true. - -choiceprefix - This specifies whether unique prefixes are able to be used - instead of the complete string. This is calculated using - tcl::prefix::match - and will display in the autogenerated - usage output. Defaults to true. - -choiceprefixdenylist {} - These choices should match exactly a choice entry in one of - the settings -choices or -choicegroups. - These will still be used in prefix calculation - but the full - choice argument must be entered to select the choice. - -choiceprefixreservelist {} - These choices are additional values used in prefix calculation. - The values will not be added to the list of available choices. - -choicegroups {} - Generally this would be used instead of -choices to allow - usage display of choices grouped by some name (or the empty - string for 'ungrouped' items which appear first). - See for example the output if 'i zlib' where choices of the - next subcommand are grouped by the names compression,channel, - streaming and checksumming. The -choices list is equivalent - to a -choicegroups dict entry where the key (groupname) is - the empty string. Both may be specified, in which case the - final list of available choices will be a union of the listed - values in -choices and the values from each choice group. - Choice values specified in -choices are effectively ungrouped - unless overridden by placing them in a choicegroup. - -choicemultiple (default {1 1}) - is a pair representing min and max number of choices - that can be present in the value. - If is a single integer it is equivalent to a - specified with the same integer for both min and max. - Max of -1 represents no upper limit. - If allows more than one choice the value is a list - consisting of items in the choices made available through - entries in -choices/-choicegroups. - -minsize (type dependant) - -maxsize (type dependant) - -range (type dependant - only valid if -type is a single item) - -typeranges (list with same number of elements as -type) - - - " - -dynamic -type boolean -default 0 -help\ - "If -dynamic is true, tstr interpolations of the form \$\{\$var\} - are re-evaluated on each call. - If the definition is being used not just as documentation, but is also - used within the function to parse args, e.g using punk::args::get_by_id, - then it should be noted that there is a slight performance penalty for the - dynamic case. - It is often not significant, perhaps depending on what vars/commands are - used but -dynamic true might be less desirable if the command is used in - inner loops in more performance-sensitive code. - " - @values -min 1 -max -1 - text -type string -multiple 1 -help\ - {Block(s) of text representing the argument definition for a command. - At least one must be supplied. If multiple, they are joined together with \n. - Using multiple text arguments may be useful to mix curly-braced and double-quoted - strings to have finer control over interpolation when defining arguments. - (this can also be handy for sections that pull resolved definition lines - from existing definitions (by id) for re-use of argument specifications and help text) - - e.g the following definition passes 2 blocks as text arguments - ${[punk::args::tclcore::argdoc::example { - punk::args::define { - @id -id ::myns::myfunc - @cmd -name myns::myfunc -help\ - "Description of command" - - %G%#The following option defines an option-value pair%R% - %G%#It may have aliases by separating them with a pipe |%R% - -fg|-foreground -default blah -type string -help\ - "In the result dict returned by punk::args::parse - the value used in the opts key will always be the last - entry, in this case -foreground" - %G%#The following option defines a flag style option (solo)%R% - -flag1 -default 0 -type none -help\ - "Info about flag1 - subsequent help lines auto-dedented by whitespace to left - of corresponding record start (in this case -flag1) - + first 4 spaces if they are all present. - This line has no extra indent relative to first line 'Info about flag1' - This line indented a further 6 chars" - - @values -min 1 -max -1 - %G%#Items that don't begin with * or - are value definitions%R% - v1 -type integer -default 0 - thinglist -type string -multiple 1 - } "@doc -name Manpage: -url [myfunc_manpage_geturl myns::myfunc]"}]} - } - }]] - - proc New_command_form {name} { - #probably faster to inline a literal dict create in the proc than to use a namespace variable - set leaderdirective_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - -ensembleparameter 0\ - ] - set optdirective_defaults [tcl::dict::create\ - -type string\ - -optional 1\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - -prefix 1\ - ] - set valdirective_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - - #form record can have running entries such as 'argspace' that aren't given to arg parser - #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict - return [dict create\ - argspace "leaders"\ - ARG_INFO [tcl::dict::create]\ - ARG_CHECKS [tcl::dict::create]\ - LEADER_DEFAULTS [tcl::dict::create]\ - LEADER_REQUIRED [list]\ - LEADER_NAMES [list]\ - LEADER_MIN ""\ - LEADER_MAX ""\ - LEADER_UNNAMED false\ - LEADERSPEC_DEFAULTS $leaderdirective_defaults\ - LEADER_CHECKS_DEFAULTS {}\ - OPT_DEFAULTS [tcl::dict::create]\ - OPT_REQUIRED [list]\ - OPT_NAMES [list]\ - OPT_ANY 0\ - OPT_MIN ""\ - OPT_MAX ""\ - OPT_SOLOS {}\ - OPTSPEC_DEFAULTS $optdirective_defaults\ - OPT_CHECKS_DEFAULTS {}\ - VAL_DEFAULTS [tcl::dict::create]\ - VAL_REQUIRED [list]\ - VAL_NAMES [list]\ - VAL_MIN ""\ - VAL_MAX ""\ - VAL_UNNAMED false\ - VALSPEC_DEFAULTS $valdirective_defaults\ - VAL_CHECKS_DEFAULTS {}\ - FORMDISPLAY [tcl::dict::create]\ - ] - - } - - proc errorstyle {args} { - #set or query the running config -errorstyle - #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? - #values: - #debug, enhanced, standard, basic, minimal - error todo - } - proc define {args} { - variable rawdef_cache - variable id_cache_rawdef - variable argdata_cache - if {[dict exists $rawdef_cache $args]} { - return [dict get [dict get $rawdef_cache $args] -id] - } else { - set id [rawdef_id $args] - if {[id_exists $id]} { - #we seem to be re-creating a previously defined id... - #clear any existing caches for this id - puts stderr "punk::args::define Redefinition of id:$id - clearing existing data" - - #dict unset argdata_cache $prevraw ;#silently does nothing if key not present - dict for {k v} $argdata_cache { - if {[dict get $v id] eq $id} { - dict unset argdata_cache $k - } - } - dict for {k v} $rawdef_cache { - if {[dict get $v -id] eq $id} { - dict unset rawdef_cache $k - } - } - dict unset id_cache_rawdef $id - } - set is_dynamic [rawdef_is_dynamic $args] - set defspace [uplevel 1 {::namespace current}] - dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic -defspace $defspace] - dict set id_cache_rawdef $id $args - return $id - } - } - - proc idquery_info {id} { - variable id_cache_rawdef - variable rawdef_cache - if {[dict exists $id_cache_rawdef $id]} { - set sep [string repeat - 40] - set rawdef [dict get $id_cache_rawdef $id] - if {[dict exists $rawdef_cache $rawdef]} { - set idinfo [dict get $rawdef_cache $rawdef] - } else { - set idinfo "" - } - set result "raw definition:" - append result \n $sep - append result \n $rawdef - append result \n $sep - append result \n "id info:" - append result \n $idinfo - append result \n $sep - variable argdata_cache - #lsearch -stride not avail (or buggy) in some 8.6 interps - search manually for now (2025). todo - modernize some time after Tcl 9.0/9.1 more widespread.(2027?) - #check for and report if id is present multiple times - set argdata_records [list] - dict for {k v} $argdata_cache { - if {[dict get $v id] eq $id} { - if {$k eq $rawdef} { - lappend argdata_records [list 1 $k $v] - } else { - lappend argdata_records [list 0 $k $v] - } - } - } - append result \n "argdata cache:" - if {![llength $argdata_records]} { - append result \n "(not present)" - } else { - append result \n "present [llength $argdata_records] time(s)" - foreach r $argdata_records { - lassign $r match k v - if {$match} { - append result \n " - present with same rawdef key" - } else { - append result \n " - present with different rawdef key" - append result \n " [punk::lib::indent $k { }]" - } - } - if {[llength $argdata_records] > 1} { - append result \n "*more than one record was not expected - review*" - } - } - append result \n $sep - return $result - } - } - - proc define2 {args} { - dict get [resolve {*}$args] id - } - - proc resolve {args} { - variable rawdef_cache - variable id_cache_rawdef - set defspace "" - if {[dict exists $rawdef_cache $args]} { - set cinfo [dict get $rawdef_cache $args] - set id [dict get $cinfo -id] - set is_dynamic [dict get $cinfo -dynamic] - if {[dict exists $cinfo -defspace]} { - set defspace [dict get $cinfo -defspace] - } - } else { - #should we really be resolving something that hasn't been defined? - set id [rawdef_id $args] - puts stderr "Warning: punk::args::resolve called with undefined id:$id" - set is_dynamic [rawdef_is_dynamic $args] - dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] - dict set id_cache_rawdef $id $args - } - - - variable argdata_cache - variable argdefcache_unresolved - - - set cache_key $args - #ideally we would use a fast hash algorithm to produce a short key with low collision probability. - #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) - #review - check if there is a built-into-tcl way to do this quickly - #for now we will just key using the whole string - #performance seems ok - memory usage probably not ideal - #quote from DKF 2021 - #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. - #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. - #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. - #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). - #> If dealing with very large amounts of data, using a database is probably a good plan. - - set textargs $args - if {![llength $args]} { - punk::args::get_by_id ::punk::args::define {} - return - } - #if {[lindex $args 0] eq "-dynamic"} { - # set is_dynamic [lindex $args 1] - # set textargs [lrange $args 2 end] - #} - - #experimental - set LVL 2 - - if {!$is_dynamic} { - if {[tcl::dict::exists $argdata_cache $cache_key]} { - return [tcl::dict::get $argdata_cache $cache_key] - } - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - if {[string first \$\{ $optionspecs] > 0} { - if {$defspace ne ""} { - #normal/desired case - #set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -paramindents none -allowcommands $optionspecs]] - } else { - #todo - deprecate/stop from happening? - puts stderr "punk::args::resolve calling tstr for id:$id with no known definition space (-defspace empty)" - set optionspecs [uplevel $LVL [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } - } - } else { - - if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { - set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel $LVL [list ::subst $param]] - } - } else { - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - #dynamic - double substitution required. - #e.g - # set DYN_CHOICES {${[::somewhere::get_choice_list]}} - # set RED [punk::ansi::a+ bold red] - # set RST [punk::ansi::a] - # punk::args::define { - # -arg -choices {${$DYN_CHOICES}} -help "${$RED}important info${$RST}" - #} - if {$defspace ne ""} { - set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } - #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) - if {[string first \$\{ $optionspecs] > 0} { - set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel $LVL [list ::subst $param]] - } - tcl::dict::set argdefcache_unresolved $cache_key $pt_params - } - } - #argdata_cache should be limited in some fashion or will be a big memory leak??? - if {[tcl::dict::exists $argdata_cache [list $optionspecs]]} { - #resolved cache version exists - return [tcl::dict::get $argdata_cache [list $optionspecs]] - } - } - - - - #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices - #default to 1 for convenience - - #checks with no default - #-minsize -maxsize -range - - - #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi - #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist - - #set opt_defaults [tcl::dict::create] - #set val_defaults [tcl::dict::create] - - #set opt_solos [list] - #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end - - set records [list] - set linebuild "" - - set linelist [split $optionspecs \n] - set lastindent "" - foreach ln $linelist { - if {[tcl::string::trim $ln] eq ""} {continue} - regexp {(\s*).*} $ln _all lastindent - break ;#break at first non-empty - } - #puts "indent1:[ansistring VIEW $lastindent]" - set in_record 0 - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - foreach rawline $linelist { - set recordsofar [tcl::string::cat $linebuild $rawline] - #ansi colours can stop info complete from working (contain square brackets) - #review - when exactly are ansi codes allowed/expected in record lines. - # - we might reasonably expect them in default values or choices or help strings - # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. - # - eg set line "set x \"a[a+ red]red[a]\"" - # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket - if {$has_punkansi} { - set test_complete [punk::ansi::ansistrip $recordsofar] - } else { - #review - #we only need to strip enough to stop interference with 'info complete' - set test_complete [string map [list \x1b\[ ""] $recordsofar] - } - if {![tcl::info::complete $test_complete]} { - #append linebuild [string trimleft $rawline] \n - if {$in_record} { - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. - #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. - #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. - #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) - #(note string first "" $str is fast and returns -1) - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline \n - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline \n - } else { - append linebuild $rawline \n - } - } else { - set in_record 1 - regexp {(\s*).*} $rawline _all lastindent - #puts "indent: [ansistring VIEW -lf 1 $lastindent]" - #puts "indent from rawline:$rawline " - append linebuild $rawline \n - } - } else { - set in_record 0 - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline - } else { - append linebuild $rawline - } - lappend records $linebuild - set linebuild "" - } - } - set cmd_info {} - set package_info {} - set id_info {} ;#e.g -children ?? - set doc_info {} - #set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table - set seealso_info {} - set keywords_info {} - ###set leader_min 0 - ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit - #set leader_max "" - #(common case of no leaders specified) - #set opt_any 0 - #set val_min 0 - #set val_max -1 ;#-1 for no limit - set DEF_definition_id $id - - #form_defs - set F [dict create _default [New_command_form _default]] - set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under - - #set ARGSPACE [dict create] ;#keyed on form - #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values - - set refs [dict create] - set record_type "" - set record_number -1 ;# - foreach rec $records { - set trimrec [tcl::string::trim $rec] - switch -- [tcl::string::index $trimrec 0] { - "" - # {continue} - } - incr record_number - set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict - if {[llength $record_values] % 2 != 0} { - #todo - avoid raising an error - store invalid defs keyed on id - error "punk::args::resolve - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" - } - # ---------------------------------------------------------- - # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. - #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! - #(form_ids_active is otherwise set in the @form handling block) - - #consider the following 2 line entry which is potentially dynamically included via a tstr: - # @form -form {* newform} - # @form -form {newform} -synopsis "cmd help ?stuff?" - #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. - #(because _default is usually 'taken over' by the first encountered form id) - #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record - #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. - - if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { - set patterns [dict get $record_values -form] - set record_form_ids [list] - foreach p $patterns { - if {[regexp {[*?\[\]]} $p]} { - #isglob - only used for matching existing forms - lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] - } else { - #don't test for existence - will define new form if necessary - lappend record_form_ids $p - } - } - #-form values could be globs that didn't match. record_form_ids could be empty.. - if {[llength $record_form_ids]} { - #only rename _default if it's the sole entry - if {[dict size $F] == 1 && [dict exists $F "_default"]} { - if {"_default" ni $record_form_ids} { - #only initial form exists - but we are mentioning new ones - #first rename the _default to first encountered new form id - #(just replace whole dict with new key - same data) - set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] - #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F - #we are only setting active because of the rename - @form is the way to change active forms list - set form_ids_active [lindex $record_form_ids 0] - } - } - foreach fid $record_form_ids { - if {![dict exists $F $fid]} { - if {$firstword eq "@form"} { - #only @form directly supplies keys - dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] - } else { - dict set F $fid [New_command_form $fid] - } - } else { - #update form with current record opts, except -form - if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } - } - } - } - } else { - #missing or empty -form - set record_form_ids $form_ids_active - if {$firstword eq "@form"} { - foreach fid $form_ids_active { - dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] - } - } - } - # ---------------------------------------------------------- - - set firstchar [tcl::string::index $firstword 0] - set secondchar [tcl::string::index $firstword 1] - if {$firstchar eq "@" && $secondchar ne "@"} { - set record_type "directive" - set directive_name $firstword - set at_specs $record_values - - switch -- [tcl::string::range $directive_name 1 end] { - dynamic { - set is_dynamic 1 - } - id { - #disallow duplicate @id line ? - #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) - - #id An id will be allocated if no id line present or the -id value is "auto" - - if {[dict exists $at_specs -id]} { - set thisid [dict get $at_specs -id] - if {$thisid ni [list $id auto]} { - error "punk::args::resolve @id mismatch existing: $id vs $thisid" - } - } - set id_info $at_specs - } - ref { - #a reference within the definition - #e.g see punk::args::tclcore ::after - #global reference dict - independent of forms - #ignore refs without an -id - #store all keys except -id - #complete overwrite if refid repeated later on - if {[dict exists $at_specs -id]} { - dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] - } - } - default { - #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple - #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) - #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) - #That is possibly too complicated and/or unnecessary? - #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? - - if {[dict exists $at_specs -id]} { - set copyfrom [get_spec [dict get $at_specs -id]] - #we don't copy the @id info from the source - #for now we only copy across if nothing set.. - #todo - bring across defaults for empty keys at targets? - #need to keep it simple enough to reason about behaviour easily.. - if {[dict size $copyfrom]} { - if {![dict size $cmd_info]} { - set cmd_info [dict get $copyfrom cmd_info] - } - if {![dict size $doc_info]} { - set doc_info [dict get $copyfrom doc_info] - } - - #foreach fid $record_form_ids { - # #only use elements with matching form id? - # #probably this feature mainly useful for _default anyway so that should be ok - # #cooperative doc sets specified in same file could share via known form ids too - # FORMDISPLAY has keys -header -body - # if {![dict size $F $fid $FORMDISPLAY]} { - # if {[dict exists $copyfrom FORMS $fid FORMDISPLAY]} { - # dict set F $fid FORMDISPLAY [dict get $copyfrom FORMS $fid FORMDISPLAY] - # } - # } - # #TODO - # #create leaders opts vals depending on position of @default line? - # #options on @default line to exclude/include sets??? - #} - } - } - } - form { - # arity system ? - #handle multiple parsing styles based on arities and keyword positions (and/or flags?) - #e.g see lseq manual with 3 different parsing styles. - #aim to produce a table/subtable for each - # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ - # -arities { - # 2 - # {3 anykeys {1 .. 1 to}} - # {4 anykeys {3 by}} - # {5 anykeys {1 .. 1 to 3 by}} - # }\ - # -fallback 1 - # ... - # @parser -synopsis "start 'count' count ??'by'? step?"\ - # -arities { - # {3 anykeys {1 count}} - # } - # ... - # @form -synopsis "count ?'by' step?"\ - # -arities { - # 1 - # {3 anykeys {1 by}} - # } - # - # see also after manual - # @form -arities {1} - # @form -arities { - # 1 anykeys {0 info} - # } - #todo - - #can we generate a form synopsis if -synopsis not supplied? - - #form id can be list of ints|names?, or * - if {[dict exists $at_specs -form]} { - set idlist [dict get $at_specs -form] - if {$idlist eq "*"} { - #* only applies to form ids that exist at the time - set idlist [dict keys $F] - } - set form_ids_active $idlist - } - #new form keys already created if they were needed (done for all records that have -form ) - } - package { - set package_info [dict merge $package_info $at_specs] - } - cmd { - #allow arbitrary - review - set cmd_info [dict merge $cmd_info $at_specs] - } - doc { - set doc_info [dict merge $doc_info $at_specs] - } - formdisplay { - #override the displayed argument table for the form. - #(formdisplay keys -header -body) - #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing - foreach fid $record_form_ids { - tcl::dict::set F $fid FORMDISPLAY [dict merge [tcl::dict::get $F $fid FORMDISPLAY] $at_specs] - } - } - opts { - foreach fid $record_form_ids { - if {[tcl::dict::get $F $fid argspace] eq "values"} { - error "punk::args::resolve - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" - } - tcl::dict::set F $fid argspace "options" - set tmp_optspec_defaults [dict get $F $fid OPTSPEC_DEFAULTS] - - foreach {k v} $at_specs { - switch -- $k { - -form { - #review - handled above - } - -any - -arbitrary - - -anyopts { - #set opt_any $v - tcl::dict::set F $fid OPT_ANY $v - } - -min { - dict set F $fid OPT_MIN $v - } - -max { - #if no -max explicitly specified, and llength OPT_NAMES == 0 and OPT_ANY == 0 - -max will be set to 0 below. - dict set F $fid OPT_MAX $v - } - -minsize - -maxsize - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted { - #review - only apply to certain types? - tcl::dict::set tmp_optspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_optspec_defaults $k2 - } - } - -type { - #v is a typelist - #foreach t $v { - # #validate? - #} - tcl::dict::set tmp_optspec_defaults -type $v - } - -range { - if {[dict exists $at_specs -type]} { - set tp [dict get $at_specs -type] - } else { - set tp [dict get $tmp_optspec_defaults -type] - } - if {[llength $tp] == 1} { - tcl::dict::set tmp_optspec_defaults -typeranges [list $v] - } else { - error "punk::args::resolve Bad @opt line. -type has length [llength $tp] (-type $tp). -range only applies to single-item type. Use -typeranges instead. @id:$DEF_definition_id" - } - } - -typeranges { - if {[dict exists $at_specs -type]} { - set tp [dict get $at_specs -type] - } else { - set tp [dict get $tmp_optspec_defaults -type] - } - if {[llength $tp] != [llength $v]} { - error "punk::args::resolve Bad @opt line. -type has length [llength $tp] (-type $tp). -typeranges has length [llength $v]. Lengths must match. @id:$DEF_definition_id" - } - tcl::dict::set tmp_optspec_defaults -typeranges $v - } - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -validationtransform { - #allow overriding of defaults for options that occur later - tcl::dict::set tmp_optspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -multiple - - -prefix { - #check is bool - if {![string is boolean -strict $v]} { - error "punk::args::resolve - Option '$k' has value '$v'of wrong type in @opts line. Must be boolean @id:$DEF_definition_id" - } - tcl::dict::set tmp_optspec_defaults $k $v - } - default { - set known { -any -anyopts -arbitrary -form -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\ - -type -range -typeranges -default -typedefaults - -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::resolve - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" - } - } - } - tcl::dict::set F $fid OPTSPEC_DEFAULTS $tmp_optspec_defaults - } ;# end foreach record_form_ids - } - leaders { - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] in [list options values]} { - error "punk::args::resolve - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" - } - set tmp_leaderspec_defaults [dict get $F $fid LEADERSPEC_DEFAULTS] - - foreach {k v} $at_specs { - switch -- $k { - -form { - #review - handled above - } - -min - - -minvalues { - if {$v < 0} { - error "punk::args::resolve - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MIN $v - #if {$leader_max == 0} { - # set leader_max -1 - #} - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::resolve - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MAX $v - } - -choiceprefix - - -choicerestricted { - if {![string is boolean -strict $v]} { - error "punk::args::resolve - invalid type of value '$v' for key '$k' in @leaders line. Must be boolean @id:$DEF_definition_id" - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -choiceinfo - -choicelabels { - if {[llength $v] %2 != 0} { - error "punk::args::resolve - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - #-choicegroups? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_leaderspec_defaults $k2 - } - } - -type { - #$v is a list of types - #foreach t $v { - #validate? - #} - #switch -- $v { - # int - integer { - # set v int - # } - # char - character { - # set v char - # } - # bool - boolean { - # set v bool - # } - # dict - dictionary { - # set v dict - # } - # list { - - # } - # index { - # set v indexexpression - # } - # default { - # #todo - disallow unknown types unless prefixed with custom- - # } - #} - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -range { - tcl::dict::set tmp_leaderspec_defaults -range $v - } - -typeranges { - tcl::dict::set tmp_leaderspec_defaults -range $v - } - -minsize - -maxsize - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefixdenylist - -choiceprefixreservelist - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform { - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -multiple { - if {![string is boolean -strict $v]} { - error "punk::args::resolve - invalid type of value '$v' for key '$k' in @leaders line. Must be boolean @id:$DEF_definition_id" - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -unnamed { - if {![string is boolean -strict $v]} { - error "punk::args::resolve - invalid type of value '$v' for key '$k' in @leaders line. Must be boolean @id:$DEF_definition_id" - } - dict set F $fid LEADER_UNNAMED $v - } - -ensembleparameter { - #review - tcl::dict::set tmp_leaderspec_defaults $k $v - #error "punk::args::resolve - -ensembleparameter not supported as a default for @leaders - only valid on actual leader arguments" - } - default { - set known { -min -form -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\ - -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted\ - -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - -unnamed\ - } - error "punk::args::resolve - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid LEADERSPEC_DEFAULTS $tmp_leaderspec_defaults - - } ;#end foreach record_form_ids - - } - values { - foreach fid $record_form_ids { - dict set F $fid argspace "values" - - set tmp_valspec_defaults [dict get $F $fid VALSPEC_DEFAULTS] - - foreach {k v} $at_specs { - switch -- $k { - -form { - #review - handled above - } - -min - - -minvalues { - if {$v < 0} { - error "punk::args::resolve - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" - } - #set val_min $v - dict set F $fid VAL_MIN $v - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::resolve - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" - } - #set val_max $v - dict set F $fid VAL_MAX $v - } - -minsize - -maxsize - -choices - -choicemultiple - -choicecolumns - - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_valspec_defaults $k $v - } - -choiceinfo - -choicegroups { - if {[llength $v] % 2 != 0} { - error "punk::args::resolve - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - # -choicegroups ?? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_valspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - index { - set v indexexpression - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -range { - tcl::dict::set tmp_valspec_defaults -range $v - } - -typeranges { - tcl::dict::set tmp_valspec_defaults -typeranges $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -multiple { - if {![string is boolean -strict $v]} { - error "punk::args::resolve - invalid type of value '$v' for key '$k' in @values line. Must be boolean @id:$DEF_definition_id" - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform { - tcl::dict::set tmp_valspec_defaults $k $v - } - -unnamed { - if {![string is boolean -strict $v]} { - error "punk::args::resolve - invalid type of value '$v' for key '$k' in @values line. Must be boolean @id:$DEF_definition_id" - } - dict set F $fid VAL_UNNAMED $v - } - default { - set known { -type -range -typeranges\ - -min -form -minvalues -max -maxvalues\ - -minsize -maxsize\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\ - -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted\ - -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - -unnamed\ - } - error "punk::args::resolve - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid VALSPEC_DEFAULTS $tmp_valspec_defaults - } - - } - seealso { - #todo! - #like @doc, except displays in footer, multiple - sub-table? - set seealso_info [dict merge $seealso_info $at_specs] - } - keywords { - #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? - set keywords_info [dict merge $keywords_info $at_specs] - } - default { - error "punk::args::resolve - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @formdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" - } - } - #record_type directive - continue - } elseif {$firstchar eq "-"} { - set argdef_values $record_values - #Note that we can get options defined with aliases e.g "-x|-suppress" - #Here we store the full string as the argname - but in the resulting dict upon parsing it will have the final - # entry as the key for retrieval e.g {leaders {} opts {-suppress true} values {} ...} - - #we can also have longopts within the list e.g "-f|--filename=" - #This accepts -f or --filename= - # (but not --filename ) - #if the clausemember is optional - then the flag can act as a solo, but a parameter can only be specified on the commandline with an = - #e.g "-x|--something= -type ?string? - #accepts all of: - # -x - # --something - # --something=blah - - - #while most longopts require the = some utilities (e.g fossil) - #accept --longname - #(fossil accepts either --longopt or --longopt=) - #For this reason, "-f|--filename" is different to gnu-style longopt "-f|--filename=" - - #for "--filename=" we can specify an 'optional' clausemember using for example -type ?string? - - #4? cases - #1) - #--longopt - # (not really a longopt - can only parse with --longopt - [optional member not supported, but could be solo if -type none]) - #2) - #--longopt= - # (gnu style longopt - parse with --longopt= - solo allowed if optional member - does not support solo via -type none) - #3) - #--longopt|--longopt= -types int - # (mixed - as fossil does - parse with --longopt= or --longopt [optional member not supported?]) - #4) - # --xxx|--longopt= -types {?int?} - #(repeating such as --longopt --longopt= not valid?) - #redundant? - #ie --longopt|--longopt= -types {?int?} - # equivalent to - # --longopt= -types {?int?} - #allow parsing -xxx only as solo and --longopt as solo or --longopt=n ? - - #the above set would not cover the edge-case where we have an optional member but we don't want --longopt to be allowed solo - #e.g - #-soloname|--longopt= -types ?int? - #allows parsing "-soloname" or "--longopt" or "--longopt=n" - #but what if we want it to mean only accept: - # "-soloname" or "--longopt=n" ?? - - #we deliberately don't support - #--longopt -type ?type? - #or -opt -type ?type? - #as this results in ambiguities and more complexity in parsing depending on where flag occurs in args compared to positionals - - #for these reasons - we can't only look for leading -- here to determine 'longopt' - - - set argname $firstword - - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - #do some basic validation here - #1 "-type none" would not be valid for "--filename=" - #2 a -type can only be optional (specified as -type ?xxx?) if at least one entry in the argname has a trailing = - #3 require --longopt if has a trailing =. ie disallow -opt= ? - - set has_equal 0 - set optaliases [split $firstword |] - if {[lsearch $optaliases *=] >=0} { - set has_equal 1 - } - #todo - if no -type specified in this flag record, we still need to check the default -type from the @opts record - which could have been - #overridden from just 'string' - if {[tcl::dict::exists $argdef_values -type]} { - set tp [tcl::dict::get $argdef_values -type] - if {[llength $tp] != 1} { - #clauselength > 1 not currently supported for flags - #e.g -myflag -type {list int} - # e.g called on commandline with cmd -myflag {a b c} 3 - #review - seems an unlikely and complicating feature to allow - evidence of tools using/supporting this in the wild not known of. - error "punk::args::resolve - Multiple space-separated arguments (as indicated by -type having multiple entries) for a flag are not supported. flag $argname -type '$tp' @id:$DEF_definition_id" - } - if {$argname eq "--"} { - if {$tp ne "none"} { - #error to explicitly attempt to configure -- as a value-taking option - error "punk::args::resolve - special flag named -- cannot be configured as a value-accepting flag. set -type none or omit -type from definition. @id:$DEF_definition_id" - } - } - if {$tp eq "none"} { - if {$has_equal} { - error "punk::args::resolve - flag type 'none' (indicating non-parameter-taking flag) is not supported when any flag member ends with = (indicating gnu-longopt style possibly taking a parameter). flag $argname -type '$tp' @id:$DEF_definition_id" - } - } elseif {[string match {\?*\?} $tp]} { - #optional flag value - if {!$has_equal} { - error "punk::args::resolve - Optional flag parameter (as indicated by leading & trailing ?) is not supported when no flag member ends with = (indicating gnu-longopt style possibly taking a parameter). flag $argname -type '$tp' @id:$DEF_definition_id" - } - } - } - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - - tcl::dict::set argdef_values -ARGTYPE option - - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - dict set F $fid argspace "options" - } elseif {[dict get $F $fid argspace] eq "values"} { - error "punk::args::resolve - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" - } - set record_type option - dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] - } - - set is_opt 1 - } else { - set argname $firstword - if {$firstchar eq "@"} { - #allow basic @@ escaping for literal argname that begins with @ - set argname [tcl::string::range $argname 1 end] - } - - set argdef_values $record_values - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - set record_type leader - tcl::dict::set argdef_values -ARGTYPE leader - #lappend leader_names $argname - set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] - if {$argname ni $temp_leadernames} { - lappend temp_leadernames $argname - tcl::dict::set F $fid LEADER_NAMES $temp_leadernames - } else { - #This can happen if the definition has repeated values - error "punk::args::resolve - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" - } - - if {[dict get $F $fid LEADER_MAX] >= 0} { - if {[dict get $F $fid LEADER_MAX] < [llength $temp_leadernames]} { - puts stderr "punk::args::resolve warning arg $argname LEADER_MAX == [dict get $F $fid LEADER_MAX] but [llength $temp_leadernames] leader names found @id:$DEF_definition_id" - dict set F $fid LEADER_MAX [llength $temp_leadernames] - } - } - } else { - set record_type value - tcl::dict::set argdef_values -ARGTYPE value - set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] - if {$argname ni $temp_valnames} { - lappend temp_valnames $argname - tcl::dict::set F $fid VAL_NAMES $temp_valnames - } else { - error "punk::args::resolve - arg $argname already present as value in '$rec' (command form:'$fid') @id:$DEF_definition_id" - } - #lappend val_names $argname - if {[dict get $F $fid VAL_MAX] >= 0} { - if {[dict get $F $fid VAL_MAX] < [llength $temp_valnames]} { - puts stderr "punk::args::resolve warning arg $argname VAL_MAX == [dict get $F $fid VAL_MAX] but [llength $temp_valnames] value names found @id:$DEF_definition_id" - dict set F $fid VAL_MAX [llength $temp_valnames] - } - } - } - } - - set is_opt 0 - } - - - #assert - we only get here if it is a value or flag specification line. - #assert argdef_values has been set to the value of record_values - - foreach fid $record_form_ids { - if {$is_opt} { - set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS] - } else { - if {[dict get $F $fid argspace] eq "values"} { - set spec_merged [dict get $F $fid VALSPEC_DEFAULTS] - } else { - set spec_merged [dict get $F $fid LEADERSPEC_DEFAULTS] - } - } - - # -> argopt argval - foreach {spec specval} $argdef_values { - #literal-key switch - bytecompiled to jumpTable - switch -- $spec { - -form { - - } - -type { - #todo - could be a list e.g {any int literal(Test)} - #case must be preserved in literal bracketed part - set typelist [list] - foreach typespec $specval { - set lc_typespec [tcl::string::tolower $typespec] - if {[string match {\?*\?} $lc_typespec]} { - set lc_type [string range $lc_typespec 1 end-1] - set optional_clausemember true - } else { - set lc_type $lc_typespec - set optional_clausemember false - } - #normalize here so we don't have to test during actual args parsing in main function - set normtype "" ;#assert - should be overridden in all branches of switch - switch -- $lc_type { - int - integer { - set normtype int - } - double - float { - #review - user may wish to preserve 'float' in help display - consider how best to implement - set normtype double - } - bool - boolean { - set normtype bool - } - char - character { - set normtype char - } - dict - dictionary { - set normtype dict - } - index - indexexpression { - set normtype indexexpression - } - "" - none - solo { - if {$is_opt} { - #review - are we allowing clauses for flags? - #e.g {-flag -type {int int}} - #this isn't very tcl like, where we'd normally mark the flag with -multiple true and - # instead require calling as: -flag -flag - #It seems this is a reasonably rare/unlikely requirement in most commandline tools. - - if {[llength $specval] > 1} { - #makes no sense to have 'none' in a clause - error "punk::args::resolve - invalid -type '$specval' for flag '$argname' ('none' in multitype) @id:$DEF_definition_id" - } - #tcl::dict::set spec_merged -type none - set normtype none - 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. - } - } else { - #solo only valid for flags - error "punk::args::resolve - invalid -type 'none|solo' for positional argument '$argname' (only valid for flags/options) @id:$DEF_definition_id" - } - } - any - anything { - set normtype any - } - ansi - ansistring { - set normtype ansistring - } - string - globstring { - set normtype $lc_type - } - literal { - if {$is_opt} { - error "punk::args::resolve - invalid -type 'literal' for flag argument '$argname' @id:$DEF_definition_id" - } - #value is the name of the argument - set normtype literal - } - default { - if {[string match literal* $lc_type]} { - #typespec may or may not be of form ?xxx? - set literal_tail [string range [string trim $typespec ?] 7 end] - set normtype literal$literal_tail - } else { - #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW - #tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - set normtype $lc_type - } - } - } - if {$optional_clausemember} { - lappend typelist ?$normtype? - } else { - lappend typelist $normtype - } - } - tcl::dict::set spec_merged -type $typelist - } - -typesynopsis { - set typecount [llength [tcl::dict::get $spec_merged -type]] - if {$typecount != [llength $specval]} { - error "punk::args::resolve - invalid -typesynopsis specification for argument '$argname'. -typesynopsis has [llength $specval] entries, but requires $typecount entries (one for each entry in -types. Use empty string list members for default) @id:$DEF_definition_id" - } - tcl::dict::set spec_merged -typesynopsis $specval - } - -solo - - -choices - -choicegroups - -choicemultiple - -choicecolumns - - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted - -choicelabels - -choiceinfo - - -minsize - -maxsize - -nocase - -multiple - - -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - - -regexprepass - -regexprefail - -regexprefailmsg - { - #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines - #review -solo 1 vs -type none ? conflicting values? - tcl::dict::set spec_merged $spec $specval - } - -range { - #allow simple case to be specified without additional list wrapping - #only multi-types require full list specification - #arg1 -type int -range {0 4} - #arg2 -type {int string} -range {{0 4} {"" ""}} - set typecount [llength [tcl::dict::get $spec_merged -type]] - if {$typecount == 1} { - tcl::dict::set spec_merged -typeranges [list $specval] - } else { - error "punk::args::resolve Bad @opt line. -type has length [llength $tp] (-type $tp). -range only applies to single-item type. Use -typeranges instead. @id:$DEF_definition_id" - } - } - -typeranges { - set typecount [llength [tcl::dict::get $spec_merged -type]] - if {$typecount != [llength $specval]} { - error "punk::args::resolve - invalid -typeranges specification for argument '$argname'. -typeranges has [llength $specval] entries, but requires $typecount entries (one for each entry in -types) @id:$DEF_definition_id" - } - tcl::dict::set spec_merged -typeranges $specval - } - -default { - #The -default is for when the entire clause is missing - #It doesn't necessarily have to have the same number of elements as the clause {llength $typelist} - #review - tcl::dict::set spec_merged -default $specval - if {![dict exists $argdef_values -optional]} { - tcl::dict::set spec_merged -optional 1 - } - } - -typedefaults { - set typecount [llength [tcl::dict::get $spec_merged -type]] - if {$typecount != [llength $specval]} { - error "punk::args::resolve - invalid -typedefaults specification for argument '$argname'. -typedefaults has [llength $specval] entries, but requires $typecount entries (one for each entry in -types) @id:$DEF_definition_id" - } - tcl::dict::set spec_merged -typedefaults $specval - } - -optional { - #applies to whole arg - not each -type - tcl::dict::set spec_merged -optional $specval - } - -ensembleparameter { - #applies to whole arg - not each -type - #review - only leaders? - tcl::dict::set spec_merged $spec $specval - } - -prefix { - #applies to whole arg - not each -type - #for flags/options - tcl::dict::set spec_merged $spec $specval - } - -validationtransform { - #string is dict only 8.7/9+ - if {[llength $specval] % 2} { - error "punk::args::resolve - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" - } - dict for {tk tv} $specval { - switch -- $tk { - -command - -function - -type - -minsize - -maxsize - -range { - } - default { - set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? - error "punk::args::resolve - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" - } - } - } - #TODO! - - } - default { - if {[string match ref-* $spec]} { - #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) - #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. - if {![tcl::dict::exists $refs $specval]} { - puts stderr "punk::args::resolve argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" - } else { - set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" - if {$targetswitch eq "-*"} { - set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id - } else { - if {[tcl::dict::exists $refs $specval $targetswitch]} { - tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] - } else { - puts stderr "punk::args::resolve argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" - } - } - } - } else { - set known_argopts [list -form -type -range -typeranges\ - -default -typedefaults -minsize -maxsize -choices -choicegroups\ - -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted\ - -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - -ensembleparameter\ - ] - error "punk::args::resolve - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" - } - } - } - } ;# end foreach {spec specval} argdef_values - - - if {$is_opt} { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - if {$argname eq "--"} { - #force -type none - in case no -type was specified and @opts -type is some other default such as string - tcl::dict::set spec_merged -type none - } - if {[tcl::dict::get $spec_merged -type] eq "none"} { - dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname] - } - } else { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - tcl::dict::set F $fid ARG_INFO $argname $spec_merged - #review existence of -default overriding -optional - #if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} {} - if {![tcl::dict::get $spec_merged -optional]} { - if {$is_opt} { - set temp_opt_required [dict get $F $fid OPT_REQUIRED] - lappend temp_opt_required $argname - dict set F $fid OPT_REQUIRED $temp_opt_required - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - set temp_leader_required [dict get $F $fid LEADER_REQUIRED] - lappend temp_leader_required $argname - dict set F $fid LEADER_REQUIRED $temp_leader_required - } else { - set temp_val_required [dict get $F $fid VAL_REQUIRED] - lappend temp_val_required $argname - dict set F $fid VAL_REQUIRED $temp_val_required - } - } - } - - - if {[tcl::dict::exists $spec_merged -default]} { - if {$is_opt} { - #tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] - tcl::dict::set F $fid OPT_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } else { - #tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] - tcl::dict::set F $fid VAL_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } - } - } - } ;# end foreach fid record_form_ids - - } ;# end foreach rec $records - - - #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { - # variable id_counter - # set DEF_definition_id "autoid_[incr id_counter]" - #} - - - #now cycle through ALL forms not just form_ids_active (record_form_ids) - dict for {fid formdata} $F { - if {[tcl::dict::get $F $fid OPT_MAX] eq ""} { - if {[llength [tcl::dict::get $F $fid OPT_NAMES]] == 0 && ![tcl::dict::get $F $fid OPT_ANY]} { - tcl::dict::set F $fid OPT_MAX 0 ;#aid in parsing to avoid scanning for opts unnecessarily - #review - when using resolved_def to create a definiation based on another - OPT_MAX may need to be overridden - a bit ugly? - } - } - # REVIEW - #no values specified - we can allow last leader to be multiple - foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { - error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" - } - } - - #todo - disallow any -multiple == true entries if any leaders have -multiple == true? - #(creates parsing ambiguity) - #ambiguity could be resolved if at least one required option/flag eg -- - #ambiguities could theoretically also be resolved with required literals or choices - or even based on argument type - #(overcomplex? todo see if any core/tcllib commands work like that) - - #only allow a single entry within VAL_NAMES to have -multiple == true - #example of command with non-trailing -multiple == true is core command: 'file copy ?-force? ?--? source ?source?... targetDir - set val_multiples 0 - foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { - if {$val_multiples > 0} { - error "bad setting -multiple true on argument spec for value '$valname' in command form:'$fid'. Only a single value argument specification can be marked with -multiple true @id:$DEF_definition_id" - } - incr val_multiples - } - } - - #todo - document that ambiguities in API are likely if both @leaders and @values used - #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) - - - dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata LEADERSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata OPTSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata VALSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - - - - - #todo - precalculate a set of 'arity' entries for each form - #We want a structure for the arg parser to get easy access and make a fast decision on which form applies - #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? - #1) after ms (1 1) - #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? - #3) after cancel id (2 2) - #4) after cancel script ?script...? (2 -1) - #5) after idle script ?script...? (1 -1) - #6) after info ?id? (1 2) - - #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) - - #in the above case we have no unique total_arity - #we would also want to consider values when selecting - #e.g given the invalid command "after cancel" - # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. - - - - set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands - #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use - #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form - #e.g commandline completion could show list of synopsis entries to select from - - set form_info [dict create] - dict for {fid fdict} $F { - dict set form_info $fid {} - dict for {optk optv} $fdict { - if {[string match -* $optk]} { - dict set form_info $fid $optk $optv - } - } - } - - set argdata_dict [tcl::dict::create\ - id $DEF_definition_id\ - cmd_info $cmd_info\ - doc_info $doc_info\ - package_info $package_info\ - seealso_info $seealso_info\ - id_info $id_info\ - FORMS $F\ - form_names [dict keys $F]\ - form_info $form_info\ - ] - - tcl::dict::set argdata_cache $cache_key $argdata_dict - if {$is_dynamic} { - #also cache resolved version - tcl::dict::set argdata_cache [list $optionspecs] $argdata_dict - } - - #tcl::dict::set id_cache_rawdef $DEF_definition_id $args - #puts "xxx:$result" - return $argdata_dict - } - - #return raw definition list as created with 'define' - # - possibly with unresolved dynamic parts - proc raw_def {id} { - variable id_cache_rawdef - set realid [real_id $id] - if {![dict exists $id_cache_rawdef $realid]} { - return "" - } - return [tcl::dict::get $id_cache_rawdef $realid] - } - - - namespace eval argdoc { - variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @formdisplay @seealso @leaders @opts @values leaders opts values} - variable resolved_def_TYPE_CHOICEGROUPS { - directives {@id @package @cmd @ref @doc @formdisplay @seealso} - argumenttypes {leaders opts values} - remaining_defaults {@leaders @opts @values} - } - - lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { - @id -id ::punk::args::resolved_def - @cmd -name punk::args::resolved_def -help\ - "Resolves or retrieves the previously resolved definition and - uses the 'spec' form to build a response in definition format. - - Pulling argument definition data from another function is a form - of tight coupling to the other function that should be done with - care. - - Note that the directives @leaders @opts @values may appear multiple - times in a source definition - applying defaults for arguments that - follow. When retrieving these - there is only a single result for - each that represents the defaults after all have been applied. - When retrieving -types * each of these will be positioned before - the arguments of that type - but this doesn't mean there was a single - leading directive for this argument type in the source definition. - Each argument has already had its complete specification recorded in - its own result. - - When manually specifying -types, the order @leaders then @opts then - @values must be maintained - but if they are placed before their - corresponding arguments, they will not affect the retrieved arguments - as these arguments are already fully spec'd. The defaults from the - source can be removed by adding @leaders, @opts @values to the - -antiglobs list, but again - this won't affect the existing arguments. - Each argument can have members of its spec overridden using the - -override dictionary. - " - @leaders -min 0 -max 0 - @opts - -return -default text -choices {text dict} - -form -default 0 -help\ - "Ordinal index or name of command form" - - #no restriction on number of types/repetitions? - -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} - -antiglobs -default {} -type list -help\ - "Glob patterns for directive or argument/flags to - be suppressed" - -override -type dict -optional 1 -default "" -help\ - "dict of dicts. Key in outer dict is the name of a - directive or an argument. Inner dict is a map of - overrides/additions (- ...) for that line. - " - @values -min 1 -max -1 - id -type string -help\ - "identifer for a punk::args definition - This will usually be a fully-qualifed - path for a command name" - pattern -type string -optional 1 -default * -multiple 1 -help\ - "glob-style patterns for retrieving value or switch - definitions. - - If -type is * and pattern is * the entire definition including - directive lines will be returned in line form. - (directives are lines beginning with - @ e.g @id, @cmd etc) - - if -type is leaders,opts or values matches from that type - will be returned. - - if -type is another directive such as @id, @doc etc the - patterns are ignored. - - " - }]] - } - - - proc resolved_def {args} { - #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. - set opts [dict create\ - -return text\ - -types {}\ - -form 0\ - -antiglobs {}\ - -override {}\ - ] - if {[llength $args] < 1} { - #must have at least id - punk::args::parse $args withid ::punk::args::resolved_def - return - } - set patterns [list] - - #a definition id must not begin with "-" ??? review - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {$a in {-type -types}} { - incr i - dict set opts -types [lindex $args $i] - } elseif {[string match -* $a]} { - incr i - dict set opts $a [lindex $args $i] - } else { - set id [lindex $args $i] - set patterns [lrange $args $i+1 end] - break - } - if {$i == [llength $args]-1} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - if {![llength $patterns]} { - set patterns [list *] - } - dict for {k v} $opts { - #set fullk [tcl::prefix::match -error "" {-return -form -types -antiglobs -override} $k] - switch -- $k { - -return - -form - -types - -antiglobs - -override {} - default { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - } - set typelist [dict get $opts -types] - if {[llength $typelist] == 0} { - set typelist {*} - } - foreach type $typelist { - if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - - - variable id_cache_rawdef - set realid [real_id $id] - if {$realid eq ""} { - return - } - - set deflist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] - - set opt_form [dict get $opts -form] - if {[string is integer -strict $opt_form]} { - set formname [lindex [dict get $specdict form_names] $opt_form] - } else { - set formname $opt_form - } - set opt_override [dict get $opts -override] - set opt_return [dict get $opts -return] - - #set arg_info [dict get $specdict ARG_INFO] - set arg_info [dict get $specdict FORMS $formname ARG_INFO] - set argtypes [dict create leaders leader opts option values value] - - set opt_antiglobs [dict get $opts -antiglobs] - set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] - set suppressed_directives [list] - set suppressed_args [list] - foreach ag $opt_antiglobs { - foreach d $directives { - if {[string match $ag $d]} { - lappend suppressed_directives $d - } - } - foreach argname [dict keys $arg_info] { - if {[string match $ag $argname]} { - lappend suppressed_args $argname - } - } - } - set suppressed_directives [lsort -unique $suppressed_directives] - set suppressed_args [lsort -unique $suppressed_args] - - set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] - - set globbed [list] - foreach pat $patterns { - set matches [dict keys $arg_info $pat] - lappend globbed {*}$matches - } - set globbed [lsort -unique $globbed] - #maintain order of original arg_info keys in globbed results - set ordered_globbed [list] - foreach a [dict keys $arg_info] { - if {$a ni $ordered_globbed && $a in $globbed} { - lappend ordered_globbed $a - } - } - set included_args [punk::args::system::punklib_ldiff $ordered_globbed $suppressed_args] - - set result "" - set resultdict [dict create] - foreach type $typelist { - switch -exact -- $type { - * { - if {"@id" in $included_directives} { - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - foreach directive {@package @cmd @doc @seealso} { - set dshort [string range $directive 1 end] - if {"$directive" in $included_directives} { - if {[dict exists $opt_override $directive]} { - append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict ${dshort}_info]" - dict set resultdict $directive [dict get $specdict ${dshort}_info] - } - } - } - - #todo @formdisplay - - - #output ordered by leader, option, value - foreach pseudodirective {leaders opts values} tp {leader option value} { - set directive "@$pseudodirective" - switch -- $directive { - @leaders {set defaults_key LEADERSPEC_DEFAULTS} - @opts {set defaults_key OPTSPEC_DEFAULTS} - @values {set defaults_key VALSPEC_DEFAULTS} - } - - if {"$directive" in $included_directives} { - if {[dict exists $opt_override "$directive"]} { - append result \n "$directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict FORMS $formname $defaults_key]" - dict set resultdict $directive [dict get $specdict FORMS $formname $defaults_key] - } - } - - if {$pseudodirective in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq $tp} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "\"$m\" [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "\"$m\" $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - - } - @id { - if {"@id" in $included_directives} { - #only a single id record can exist - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - } - @package - @cmd - @doc - @seealso { - if {"$type" in $included_directives} { - set tp [string range $type 1 end] ;# @package -> package - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict ${tp}_info]" - dict set resultdict $type [dict get $specdict ${tp}_info] - } - } - #todo @formdisplay - } - @leaders - @opts - @values { - #these are the active defaults for further arguments - if {"$type" in $included_directives} { - switch -- $type { - @leaders {set defaults_key LEADERSPEC_DEFAULTS} - @opts {set defaults_key OPTSPEC_DEFAULTS} - @values {set defaults_key VALSPEC_DEFAULTS} - } - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS]" - dict set resultdict $type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] - } - } - } - leaders - opts - values { - #pseudo-directives - if {$type in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "\"$m\" [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "\"$m\" $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - default { - } - } - if {$opt_return eq "text"} { - return $result - } else { - return $resultdict - } - } - } - - proc resolved_def_values {id {patternlist *}} { - variable id_cache_rawdef - set realid [real_id $id] - if {$realid ne ""} { - set deflist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [resolve {*}$deflist] - set arg_info [dict get $specdict ARG_INFO] - set valnames [dict get $specdict VAL_NAMES] - set result "" - if {$patternlist eq "*"} { - foreach v $valnames { - set def [dict get $arg_info $v] - set def [dict remove $def -ARGTYPE] - append result \n "$v $def" - } - return $result - } else { - foreach pat $patternlist { - set matches [dict keys $arg_info $pat] - set matches [lsearch -all -inline -glob $valnames $pat] - foreach m $matches { - set def [dict get $arg_info $m] - set def [dict remove $def -ARGTYPE] - append result \n "$m $def" - } - } - return $result - } - } - } - #proc resolved_def_leaders ?? - #proc resolved_def_opts ?? - - proc get_spec {id} { - set deflist [raw_def $id] - if {$deflist eq ""} { - return - } - return [resolve {*}$deflist] - #if {[id_exists $id]} { - # return [resolve {*}[raw_def $id]] - #} - } - proc is_dynamic {id} { - variable id_cache_rawdef - variable rawdef_cache - set deflist [raw_def $id] - if {[dict exists $rawdef_cache $deflist -dynamic]} { - return [dict get $rawdef_cache $deflist -dynamic] - } - return [rawdef_is_dynamic $deflist] - #@dynamic only has meaning as 1st element of a def in the deflist - } - - #@id must be within first 4 lines of a block - or assign auto - #review - @dynamic block where -id not explicitly set? - disallow? - proc rawdef_id {rawdef} { - set id "" - foreach d $rawdef { - foreach ln [lrange [split $d \n] 0 4] { - if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { - if {$firstword eq "@id"} { - if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { - set id [dict get $rest -id] - break - } - } - } - } - if {$id ne ""} { - break - } - } - if {$id eq "" || [string tolower $id] eq "auto"} { - variable id_counter - set id "autoid_[incr id_counter]" - } - #puts "==>id: $id" - return $id - } - #test the rawdef for @dynamic directive - proc rawdef_is_dynamic {rawdef} { - #temporary - old way - set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] - if {$flagged_dynamic} { - return true - } - foreach d $rawdef { - if {[regexp {\s*(\S+)} $d _match firstword]} { - if {$firstword eq "@dynamic"} { - return true - } - } - } - return false - } - - variable aliases - set aliases [dict create] - - lappend PUNKARGS [list { - @id -id ::punk::args::get_ids - @cmd -name punk::args::get_ids -help\ - "return list of ids for argument definitions" - @values -min 0 -max 1 - match -default * -help\ - "exact id or glob pattern for ids" - }] - proc get_ids {{match *}} { - variable id_cache_rawdef - variable aliases - return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] - } - - #we don't automatically test for (autodef)$id - only direct ids and aliases - proc id_exists {id} { - variable aliases - if {[tcl::dict::exists $aliases $id]} { - return 1 - } - variable id_cache_rawdef - tcl::dict::exists $id_cache_rawdef $id - } - proc set_alias {alias id} { - variable aliases - dict set aliases $alias $id - } - proc unset_alias {alias} { - variable aliases - dict unset aliases $alias - } - proc get_alias {alias} { - variable aliases - if {[dict exists $aliases $alias]} { - return [tcl::dict::get $aliases $alias] - } - } - - proc real_id {id} { - variable id_cache_rawdef - variable aliases - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } else { - set check_updates [list [namespace qualifiers $id]] - #puts stderr "---->real_id '$id' update_definitions $check_updates" - if {![llength [update_definitions $check_updates]]} { - #nothing new loaded - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } else { - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } - } - } - - proc status {} { - upvar ::punk::args::register::NAMESPACES registered - upvar ::punk::args::register::loaded_packages loaded_packages - upvar ::punk::args::register::loaded_info loaded_info - upvar ::punk::args::register::scanned_packages scanned_packages - upvar ::punk::args::register::scanned_info scanned_info - set result "" - # [format %-${w0}s $idtail] - set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] - append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n - set width_c2 [string length "Scanned_ids"] - set width_c3 [string length "Scantime_us"] - set width_c4 [string length "Loaded_defs"] - set width_c5 [string length "Loadtime_us"] - set count_unloaded 0 - set count_loaded 0 - foreach ns $registered { - if {$ns in $scanned_packages} { - set ids [dict get $scanned_info $ns idcount] - set scan_us [dict get $scanned_info $ns time] - } else { - set ids "" - set scan_us "" - } - if {$ns in $loaded_packages} { - incr count_loaded - set ldefs [dict get $loaded_info $ns defcount] - set load_us [dict get $loaded_info $ns time] - } else { - incr count_unloaded - set ldefs "" - set load_us "" - } - append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n - } - append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" - return $result - } - - #scanned_packages (list) - #namespace_docpackages (dict) - proc update_definitions {{nslist *}} { - #puts "----> update_definitions '$nslist'" - if {[set gposn [lsearch $nslist {}]] >= 0} { - lset nslist $gposn :: - } - upvar ::punk::args::register::NAMESPACES registered ;#list - upvar ::punk::args::register::loaded_packages loaded_packages ;#list - upvar ::punk::args::register::loaded_info loaded_info ;#dict - upvar ::punk::args::register::scanned_packages scanned_packages ;#list - upvar ::punk::args::register::scanned_info scanned_info ;#dict - upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict - - - #puts stderr "-->update_definitions '$nslist'" - #needs to run quickly - especially when no package namespaces to be scanned for argdefs - #e.g - gets called for each subcommand of an ensemble (could be many) - # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. - #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. - # -- --- --- --- --- --- - # common-case fast-path - - if {[llength $loaded_packages] == [llength $registered]} { - #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. - #assert - if all are registered - then all have been scanned - return {} - } - # -- --- --- --- --- --- - - set unscanned [punklib_ldiff $registered $scanned_packages] - if {[llength $unscanned]} { - foreach pkgns $unscanned { - set idcount 0 - set ts_start [clock microseconds] - if {[info exists ${pkgns}::PUNKARGS]} { - set seen_documentedns [list] ;#seen per pkgns - foreach definitionlist [set ${pkgns}::PUNKARGS] { - #namespace eval $evalns [list punk::args::define {*}$definitionlist] - set id [rawdef_id $definitionlist] - if {[string match autoid_* $id]} { - puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" - puts stderr "definition:\n" - foreach d $definitionlist { - set out "" - foreach ln [split $d \n] { - append out " " $ln \n - } - puts $out - } - continue - } - #todo - detect duplicate ids (last will silently win.. should be reported somewhere) - incr idcount - set documentedns [namespace qualifiers $id] - if {$documentedns eq ""} {set documentedns ::} - if {$documentedns ni $seen_documentedns} { - #don't add own ns as a key in namespace_docpackages - if {$documentedns ne $pkgns} { - dict lappend namespace_docpackages $documentedns $pkgns - } - lappend seen_documentedns $documentedns - } - } - } - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - dict set scanned_info $pkgns [dict create time $diff idcount $idcount] - #we count it as scanned even if PUNKARGS didn't exist - #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) - lappend scanned_packages $pkgns - } - } - - - - if {"*" in $nslist} { - set needed [punklib_ldiff $registered $loaded_packages] - } else { - set needed [list] - foreach pkgns $nslist { - if {![string match ::* $pkgns]} { - puts stderr "warning: update_definitions received unqualified ns: $pkgns" - set pkgns ::$pkgns - } - if {$pkgns in $registered && $pkgns ni $loaded_packages} { - lappend needed $pkgns - } - #argdoc sub namespace is a standard place to put defs that match the namespace below - #(generally the PUNKARGS in a namespace should apply to own ns) - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { - lappend needed $docns - } - } - if {[dict exists $namespace_docpackages $pkgns]} { - #this namespace has other argdef sources - foreach docns [dict get $namespace_docpackages $pkgns] { - if {$docns ni $loaded_packages} { - lappend needed $docns - } - } - } - } - } - - - - set newloaded [list] - foreach pkgns $needed { - #puts stderr "update_definitions Loading: $pkgns" - set ts_start [clock microseconds] - set def_count 0 - if {![catch { - if {[info exists ${pkgns}::PUNKARGS]} { - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - namespace eval ${pkgns}::argdoc { - set epath [namespace path] - set pkgns [namespace parent] - if {$pkgns ni $epath} { - namespace path [list {*}$epath $pkgns] ;#add to tail - } - - } - set evalns $docns - } else { - set evalns $pkgns - } - foreach definitionlist [set ${pkgns}::PUNKARGS] { - namespace eval $evalns [list punk::args::define {*}$definitionlist] - incr def_count - } - } - - #process list of 2-element lists - if {[info exists ${pkgns}::PUNKARGS_aliases]} { - foreach adef [set ${pkgns}::PUNKARGS_aliases] { - punk::args::set_alias {*}$adef - } - } - } errMsg]} { - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - lappend loaded_packages $pkgns - lappend newloaded $pkgns - dict set loaded_info $pkgns [dict create time $diff defcount $def_count] - } else { - puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" - } - } - return $newloaded - } - - #for use within get_dict only - #This mechanism gets less-than-useful results for oo methods - #e.g {$obj} - proc Get_caller {} { - #set call_level -3 ;#for get_dict call - set call_level -4 - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - #puts "-->$cmdinfo" - #puts "-->[tcl::info::frame -3]" - while {[string last \n $cmdinfo] >= 1} { - #looks like a script - haven't gone up far enough? - #(e.g patternpunk oo system: >punk . poses -invalidoption) - incr call_level -1 - if {[catch { - set nextup [tcl::info::frame $call_level] - } ]} { - break - } - set cmdinfo [tcl::dict::get $nextup cmd] - set caller [regexp -inline {\S+} $cmdinfo] - if {[interp alias {} $caller] ne ""} { - #puts "found alias for caller $caller to [interp alias {} $caller]" - #see if we can go further - incr call_level -1 - if {[catch { - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - } errM ]} { - puts "err: $errM" - break - } - } - } - set caller [regexp -inline {\S+} $cmdinfo] - if {$caller eq "namespace"} { - # review - message? - set cmdinfo "Get_caller (punk::args::get_dict?) called from namespace" - } - return $cmdinfo - } - - - # -------------------------------------- - #test of Get_caller - lappend PUNKARGS [list { - @id -id ::punk::args::test1 - @values -min 0 -max 0 - }] - proc test_get_dict {args} { - punk::args::get_dict [punk::args::raw_def ::punk::args::test1] $args - } - proc test_get_by_id {args} { - punk::args::get_by_id ::punk::args::test1 $args - } - #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. - proc test_callers {args} { - if {![llength $args]} { - puts "these test functions accept no arguments" - puts "Call with arg(s) to compare error output" - } - - if {[catch {test_get_dict {*}$args} errM]} { - puts $errM - } - puts "------------" - if {[catch {test_get_by_id {*}$args} errM]} { - puts $errM - } - return done - } - # -------------------------------------- - - set map "" - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::arg_error - @cmd -name punk::args::arg_error -help\ - "Generates a table (by default) of usage information for a command. - A trie system is used to create highlighted prefixes for command - switches and for subcommands or argument/switch values that accept - a defined set of choices. These prefixes match the mechanism used - to validate arguments (based on tcl::prefix::match). - - This function is called during the argument parsing process - (if the definition is not only being used for documentation) - It is also called by punk::args::usage which is in turn - called by the punk::ns introspection facilities which creates - on the fly definitions for some commands such as ensembles and - oo objects where a manually defined one isn't present. - " - @leaders -min 2 -max 2 - msg -type string -help\ - "Error message to display immediately prior to usage table. - May be empty string to just display usage. - " - spec_dict -type dict -help\ - "Dictionary of argument specifications. - This is the internal format parsed from - the textual definition. It contains the data - organised/optimised to allow the final arg - parser/validator to make decisions. - " - @opts - -badarg -type string -help\ - "name of an argument to highlight" - -parsedargs -type dict -help\ - "Result of successful punk::pargs::parse - (currently only looks at 'received')" - -aserror -type boolean -help\ - "If true, the usage table is raised as an error message, - otherwise it is returned as a value." - -return -choices {string table tableobject} -choicelabels { - string "no table layout" - tableobject "table object cmd" - table "full table layout" - } - -scheme -default error -choices {nocolour info error} - -form -default 0 -help\ - "Ordinal index or name of command form" - }] ] - - if {[catch {package require punk::ansi}]} { - proc punk::args::a {args} {} - proc punk::args::a+ {args} {} - } else { - namespace eval ::punk::args { - namespace import ::punk::ansi::a ::punk::ansi::a+ - } - } - variable arg_error_CLR - array set arg_error_CLR {} - set arg_error_CLR(errormsg) [a+ brightred] - set arg_error_CLR(title) "" - set arg_error_CLR(check) [a+ brightgreen] - set arg_error_CLR(solo) [a+ brightcyan] - set arg_error_CLR(choiceprefix) [a+ underline] - set arg_error_CLR(badarg) [a+ brightred] - set arg_error_CLR(goodarg) [a+ green strike] - set arg_error_CLR(goodchoice) [a+ reverse] - set arg_error_CLR(linebase_header) [a+ white] - set arg_error_CLR(cmdname) [a+ brightwhite] - set arg_error_CLR(groupname) [a+ bold] - set arg_error_CLR(ansiborder) [a+ bold] - set arg_error_CLR(ansibase_header) [a+ bold] - set arg_error_CLR(ansibase_body) [a+ white] - variable arg_error_CLR_nocolour - array set arg_error_CLR_nocolour {} - set arg_error_CLR_nocolour(errormsg) [a+ bold] - set arg_error_CLR_nocolour(title) [a+ bold] - set arg_error_CLR_nocolour(check) "" - set arg_error_CLR_nocolour(solo) "" - set arg_error_CLR_nocolour(badarg) [a+ reverse] ;#? experiment - set arg_error_CLR_nocolour(goodarg) [a+ strike] - set arg_error_CLR_nocolour(cmdname) [a+ bold] - set arg_error_CLR_nocolour(linebase_header) "" - set arg_error_CLR_nocolour(linebase) "" - set arg_error_CLR_nocolour(ansibase_body) "" - variable arg_error_CLR_info - array set arg_error_CLR_info {} - set arg_error_CLR_info(errormsg) [a+ brightred bold] - set arg_error_CLR_info(title) [a+ brightyellow bold] - set arg_error_CLR_info(check) [a+ brightgreen bold] - set arg_error_CLR_info(choiceprefix) [a+ brightgreen bold] - set arg_error_CLR_info(groupname) [a+ cyan bold] - set arg_error_CLR_info(ansiborder) [a+ brightcyan bold] - set arg_error_CLR_info(ansibase_header) [a+ cyan] - set arg_error_CLR_info(ansibase_body) [a+ white] - variable arg_error_CLR_error - array set arg_error_CLR_error {} - set arg_error_CLR_error(errormsg) [a+ brightred bold] - set arg_error_CLR_error(title) [a+ brightcyan bold] - set arg_error_CLR_error(check) [a+ brightgreen bold] - set arg_error_CLR_error(choiceprefix) [a+ brightgreen bold] - set arg_error_CLR_error(groupname) [a+ cyan bold] - set arg_error_CLR_error(ansiborder) [a+ brightyellow bold] - set arg_error_CLR_error(ansibase_header) [a+ yellow] - set arg_error_CLR_error(ansibase_body) [a+ white] - - - #bas ic recursion blocker - variable arg_error_isrunning 0 - proc arg_error {msg spec_dict args} { - #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. - #accept an option here so that we can still use full output for usage requests. - #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args - #Development/experimentation may be done with full table-based error reporting - but for production release it - #may be desirable to reduce overhead on catches. - #consider per-namespace or namespace-tree configurability. - #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due - #to resource availability etc - so the slower error generation time may not always be a problem. - #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling - #code which has no use for the enhanced error info. - #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. - #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system - #todo - #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error - #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) - - #todo - document unnamed leaders and unnamed values where -min and/or -max specified - #e.g punk::args::parse {} withdef {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} - #only |?-x?|string|... is shown in the output table. - #should be something like: - # |arg | - # |?-x? | - # |arg | - # |?arg...?| - # Where/how to specify counts? - #also.. - # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? - # - - - #limit colours to standard 16 so that themes can apply to help output - variable arg_error_isrunning - if {$arg_error_isrunning} { - error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" - } - - if {[llength $args] %2 != 0} { - error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" - } - - set arg_error_isrunning 1 - - set badarg "" - set parsedargs [dict create] ;#dict with keys: leaders,opts,values,received,solos,multis (as from punk::args::parse) - set goodargs [list] - set returntype table ;#table as string - set as_error 1 ;#usual case is to raise an error - set scheme error - set form 0 - dict for {k v} $args { - set fullk [tcl::prefix::match -error "" {-badarg -parsedargs -aserror -return -scheme -form} $k] - switch -- $fullk { - -badarg { - set badarg $v - } - -parsedargs { - #todo? - dict for {set setinfo} $v { - switch -- $set { - received { - foreach {r rpos} $setinfo { - if {$r ni $goodargs} { - lappend goodargs $r - } - } - } - } - } - set parsedargs $v - } - -aserror { - if {![string is boolean -strict $v]} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" - } - set as_error $v - } - -scheme { - set scheme $v - } - -return { - if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" - } - set returntype $v - } - -form { - set form $v - } - default { - set arg_error_isrunning 0 - error "arg_error invalid option $k. Known_options: -badarg -parsedargs -aserror -scheme -return -form" - } - } - } - #todo - scheme - use config and iterm toml definitions etc - switch -- $scheme { - "" - -nocolor - -nocolour { - set scheme nocolour - } - info - error {} - default { - set scheme na - } - } - set formnames [dict get $spec_dict form_names] - if {[string is integer -strict $form]} { - if {$form < 0 || $form > [llength $formnames]-1} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" - } - set selected_forms [list [lindex $formnames $form]] - } else { - if {$form eq "*"} { - set selected_forms $formnames - } else { - if {$form in $formnames} { - set selected_forms [list $form] - } else { - set arg_error_isrunning 0 - error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" - } - } - } - - - #hack some basics for now. - #for coloured schemes - use bold as well as brightcolour in case colour off. - upvar ::punk::args::arg_error_CLR CLR - - switch -- $scheme { - nocolour { - variable arg_error_CLR_nocolour - array set CLR [array get arg_error_CLR_nocolour - } - info { - variable arg_error_CLR_info - array set CLR [array get arg_error_CLR_info] - } - error { - variable arg_error_CLR_error - array set CLR [array get arg_error_CLR_error] - } - na { - } - } - - - #set RST [a] - set RST "\x1b\[m" - set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. - - #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error - #e.g list_as_table - - # use basic colours here to support terminals without extended colours - #todo - add checks column (e.g -minsize -maxsize) - set errmsg $msg - if {![catch {package require textblock}]} { - set has_textblock 1 - } else { - set has_textblock 0 - #couldn't load textblock package - #just return the original errmsg without formatting - } - set use_table 0 - if {$has_textblock && $returntype in {table tableobject}} { - set use_table 1 - } - set errlines [list] ;#for non-textblock output - if {[catch { - if {$use_table} { - append errmsg \n - } else { - if {($returntype in {table tableobject}) && !$has_textblock} { - append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n - } else { - append errmsg \n - } - } - set cmdname [Dict_getdef $spec_dict cmd_info -name ""] - set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] - - set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] - set docurl [Dict_getdef $spec_dict doc_info -url ""] - - #set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] - #set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] - #if {"$argdisplay_header$argdisplay_body" eq ""} { - # set is_custom_argdisplay 0 - #} else { - # set is_custom_argdisplay 1 - #} - - #temp - TODO - set argdisplay_header "" - set argdisplay_body "" - set is_custom_argdisplay 0 - - - set blank_header_col [list] - if {$cmdname ne ""} { - lappend blank_header_col "" - set cmdname_display $CLR(cmdname)$cmdname$RST - } else { - set cmdname_display "" - } - if {$cmdhelp ne ""} { - lappend blank_header_col "" - #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] - set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] - } else { - set cmdhelp_display "" - } - if {$docurl ne ""} { - lappend blank_header_col "" - set docurl_display [a+ white]$docurl$RST - } else { - set docurl_display "" - } - #synopsis - set synopsis "" - set form_info [dict get $spec_dict form_info] - dict for {fid finfo} $form_info { - set form_synopsis [Dict_getdef $finfo -synopsis ""] - if {$form_synopsis eq ""} { - #todo - set form_synopsis [punk::args::synopsis -form $fid [dict get $spec_dict id]] - if {[string length $form_synopsis] > 90} { - # - set form_synopsis [punk::args::synopsis -return summary -form $fid [dict get $spec_dict id]] - } - if {[string match (autodef)* $form_synopsis]} { - set form_synopsis [string range $form_synopsis 9 end] - } - } - if {$fid in $selected_forms} { - set form_synopsis [punk::ansi::a+ underline]$form_synopsis[punk::ansi::a+ nounderline] - } - append synopsis $form_synopsis \n - } - if {$synopsis ne ""} { - set synopsis [string trimright $synopsis \n] - lappend blank_header_col "" - } - - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - if {$use_table} { - set t [textblock::class::table new "$CLR(title)Usage$RST"] - $t add_column -headers $blank_header_col -minwidth 3 - $t add_column -headers $blank_header_col - - if {!$is_custom_argdisplay} { - lappend blank_header_col "" - #spanned columns in default argdisplay area - $t add_column -headers $blank_header_col ;#Default - $t add_column -headers $blank_header_col ;#Multi - $t add_column -headers $blank_header_col ;#Help - set arg_colspans {1 4 0 0 0} - } else { - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - set arg_colspans {1 1} - } - } - set h 0 - if {$cmdname ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] - } else { - lappend errlines "COMMAND: $cmdname_display" - } - incr h - } - if {$cmdhelp ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] - } else { - lappend errlines "Description: $cmdhelp_display" - } - incr h - } - if {$docurl ne ""} { - if {![catch {package require punk::ansi}]} { - set docurl [punk::ansi::hyperlink $docurl] - } - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] - } else { - lappend errlines "$docname $docurl_display" - } - incr h - } - if {$synopsis ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Synopsis: [punk::ansi::ansiwrap brightwhite $synopsis]] - } else { - #todo - lappend errlines "Synopsis:\n$synopsis" - } - incr h - } - - - if {$use_table} { - if {$is_custom_argdisplay} { - if {$argdisplay_header ne ""} { - $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] - } - } else { - $t configure_header $h -values {Arg Type Default Multi Help} - } - } else { - lappend errlines " --ARGUMENTS-- " - } - - if {$is_custom_argdisplay} { - if {$use_table} { - #using overall container table - #header already added - #TODO - review textblock::table features - #we can't currently span columns within the table body. - #This feature could allow hidden data columns (and sort on hidden col?) - #potentially require coordination with header colspans? - $t add_row [list "" $argdisplay_body] - } else { - if {$argdisplay_header ne ""} { - lappend errlines $argdisplay_header - } - lappend errlines {*}$argdisplay_body - } - } else { - - #set A_DEFAULT [a+ brightwhite Brightgreen] - set A_DEFAULT "" - set A_BADARG $CLR(badarg) - set A_GOODARG $CLR(goodarg) - set A_GOODCHOICE $CLR(goodchoice) - set greencheck $CLR(check)\u2713$RST ;#green tick - set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply - if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { - #A_PREFIX can resolve to empty string if colour off - #we then want to display underline instead - set A_PREFIX [a+ underline] - set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space - } else { - set A_PREFIXEND $RST - } - - #TODO - foreach fid - set fid [lindex $selected_forms 0] - set form_dict [dict get $spec_dict FORMS $fid] - - set opt_names [list] - set opt_names_display [list] - set lookup_optset [dict create] - if {[llength [dict get $form_dict OPT_NAMES]]} { - set all_opts [list] - foreach optset [dict get $form_dict OPT_NAMES] { - #e.g1 "-alias1|-realname" - #e.g2 "-f|--filename" (fossil longopt style) - #e.g3 "-f|--filename=" (gnu longopt style) - set optmembers [split $optset |] - lappend all_opts {*}$optmembers - foreach o $optmembers { - dict set lookup_optset $o $optset - #goodargs - } - } - set full_goodargs [list] - #goodargs may have simplified entries for received opts of form -alias1|-alias2|-realname - #map -realname to full argname - foreach g $goodargs { - if {[string match -* $g] && [dict exists $lookup_optset $g]} { - lappend full_goodargs [dict get $lookup_optset $g] - } else { - lappend full_goodargs $g - } - } - set goodargs $full_goodargs - if {![catch {package require punk::trie}]} { - #todo - reservelist for future options - or just to affect the prefix calculation - # (similar to -choiceprefixreservelist) - - set trie [punk::trie::trieclass new {*}$all_opts --] - set idents [dict get [$trie shortest_idents ""] scanned] - #todo - check opt_prefixdeny - - $trie destroy - foreach optset [dict get $form_dict OPT_NAMES] { - set arginfo [dict get $form_dict ARG_INFO $optset] - if {[dict get $arginfo -prefix]} { - set opt_members [split $optset |] - set odisplay [list] - foreach opt $opt_members { - set id [dict get $idents $opt] - #REVIEW - if {$id eq $opt} { - set prefix $opt - set tail "" - } else { - set idlen [string length $id] - set prefix [string range $opt 0 $idlen-1] - set tail [string range $opt $idlen end] - } - lappend odisplay $A_PREFIX$prefix$A_PREFIXEND$tail - } - #lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail - lappend opt_names_display [join $odisplay |] - } else { - lappend opt_names_display $optset - } - #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] - lappend opt_names $optset - } - } else { - set opt_names [dict get $form_dict OPT_NAMES] - set opt_names_display $opt_names - } - } - set leading_val_names [dict get $form_dict LEADER_NAMES] - set trailing_val_names [dict get $form_dict VAL_NAMES] - - #dict for {argname info} [tcl::dict::get $form_dict arg_info] { - # if {![string match -* $argname]} { - # lappend leading_val_names [lpop trailing_val_names 0] - # } else { - # break - # } - #} - #if {![llength $leading_val_names] && ![llength $opt_names]} { - # #all vals were actually trailing - no opts - # set trailing_val_names $leading_val_names - # set leading_val_names {} - #} - set leading_val_names_display $leading_val_names - set trailing_val_names_display $trailing_val_names - #puts "--> parsedargs: $parsedargs" - set parsed_leaders [Dict_getdef $parsedargs leaders {}] - set parsed_opts [Dict_getdef $parsedargs opts {}] - set parsed_values [Dict_getdef $parsedargs values {}] - - #display options first then values - foreach argumentclassinfo [list [list leaders $leading_val_names_display $leading_val_names $parsed_leaders] [list opts $opt_names_display $opt_names $parsed_opts] [list values $trailing_val_names_display $trailing_val_names $parsed_values]] { - lassign $argumentclassinfo argumentclass argnames_display argnames parsedvalues - - foreach argshow $argnames_display arg $argnames { - set arginfo [dict get $form_dict ARG_INFO $arg] - if {[dict exists $arginfo -default]} { - set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" - } else { - set default "" - } - set help [Dict_getdef $arginfo -help ""] - set allchoices_originalcase [list] - set choices [Dict_getdef $arginfo -choices {}] - set choicegroups [Dict_getdef $arginfo -choicegroups {}] - set choicemultiple [dict get $arginfo -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] - set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] - set choiceprefixreservelist [Dict_getdef $arginfo -choiceprefixreservelist {}] ;#names used to calc prefix - but not available as actual choice. - if {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - set is_multiple 1 - } else { - set multiple "" - set is_multiple 0 - } - if {[dict exists $choicegroups ""]} { - dict lappend choicegroups "" {*}$choices - } else { - set choicegroups [dict merge [dict create "" $choices] $choicegroups] - } - #review - does choiceprefixdenylist need to be added? - dict for {groupname clist} $choicegroups { - lappend allchoices_originalcase {*}$clist - } - set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] - - if {$has_choices} { - if {$help ne ""} {append help \n} - if {[dict get $arginfo -nocase]} { - set casemsg " (case insensitive)" - set allchoices_prefixcalc [list {*}[string tolower $allchoices_originalcase] {*}$choiceprefixreservelist] - } else { - set casemsg " (case sensitive)" - set allchoices_prefixcalc [list {*}$allchoices_originalcase {*}$choiceprefixreservelist] - } - if {[dict get $arginfo -choiceprefix]} { - set prefixmsg " (choice prefix allowed)" - } else { - set prefixmsg "" - } - set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] - set choiceinfodict [Dict_getdef $arginfo -choiceinfo {}] - set formattedchoices [dict create] ;#use dict rather than array to preserve order - append help " Choices$prefixmsg$casemsg" - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - if {$choicemultiple_max == -1} { - append help \n " The value can be a list of $choicemultiple_min or more of these choices" - } else { - if {$choicemultiple_min eq $choicemultiple_max} { - append help \n " The value must be a list of $choicemultiple_min of these choices" - } else { - append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" - } - } - } - if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c [join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } else { - #set formattedchoices $choicegroups - #set formattedchoices [dict get $arginfo -choices] - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c [join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } - } else { - if {[catch { - set trie [punk::trie::trieclass new {*}$allchoices_prefixcalc] - set idents [dict get [$trie shortest_idents ""] scanned] - if {[dict get $arginfo -nocase]} { - #idents were calculated on lcase - remap keys in idents to original casing - set actual_idents $idents - foreach ch $allchoices_originalcase { - if {![dict exists $idents $ch]} { - #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting - #The actual testing is done in get_dict - dict set actual_idents $ch [dict get $idents [string tolower $ch]] - } - } - set idents $actual_idents - #puts "-----" - #puts "idents $idents" - } - - $trie destroy - dict for {groupname clist} $choicegroups { - foreach c $clist { - if {$c in $choiceprefixdenylist} { - set shortestid $c - } else { - set shortestid [dict get $idents $c] - } - if {$shortestid eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $shortestid] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set mk " [join $markers {}]" - } else { - set mk "" - } - set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]$mk" - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - #puts "-- parsed:$parsedvalues arg:$arg c:$c" - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } errM]} { - #this failure can happen if -nocase is true and there are ambiguous entries - #e.g -nocase 1 -choices {x X} - puts stderr "prefix marking failed\n$errM" - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c [join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } else { - #set formattedchoices $choicegroups - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c[join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } - - } - } - set choicetable_objects [list] - set choicetable_footers [dict create] - dict for {groupname formatted} $formattedchoices { - set numcols $choicecolumns ;#todo - dynamic? - if {[llength $formatted] < $numcols} { - #don't show blank cells if single line of results - set numcols [llength $formatted] - } - if {$numcols > 0} { - if {$use_table} { - #risk of recursing - #TODO -title directly in list_as_table - set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] - lappend choicetable_objects $choicetableobj - $choicetableobj configure -title $CLR(groupname)$groupname - #append help \n[textblock::join -- " " [$choicetableobj print]] - } else { - if {$groupname ne ""} { - append help \n \n "$CLR(groupname)Group: $groupname$RST" - } else { - append help \n - } - append help \n [join $formatted \n] - } - } else { - #we were given an empty set of choices. - #probably an error in the definition - but could happen if dynamically generated. - #(e.g ensemble where unknown mechanism is used for subcommands?) - #better to just display that there were none rather than totally break the usage output. - if {$usetable} { - #these will be displayed after all table entries - if {$groupname eq ""} { - dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" - } else { - dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" - } - } else { - if {$groupname eq ""} { - append help \n " " $CLR(errormsg)(no choices defined)$RST - } else { - append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST - } - } - } - } - set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width - foreach obj $choicetable_objects { - dict lappend twidths_by_colcount [$obj column_count] [$obj width] - } - foreach obj $choicetable_objects { - set cols [$obj column_count] - set widths [dict get $twidths_by_colcount $cols] - set max [tcl::mathfunc::max {*}$widths] - $obj configure -minwidth $max ;#expand smaller ones - set i 0 - while {$i < $cols} { - #keep text aligned left on expanded tables - $obj configure_column $i -blockalign left - incr i - } - - append help \n[textblock::join -- " " [$obj print]] - #set ansititle [dict get [$obj configure -title] value] - $obj destroy - } - if {[dict size $choicetable_footers]} { - foreach groupname [dict keys $formattedchoices] { - if {[dict exists $choicetable_footers $groupname]} { - append help \n [dict get $choicetable_footers $groupname] - } - } - } - - #review. use -type to restrict additional choices - may be different to values in the -choices - if {![dict get $arginfo -choicerestricted]} { - #when -choicemultiple - the -type refers to each selection - if {[dict get $arginfo -type] eq "string"} { - append help "\n (values not in defined choices are allowed)" - } else { - append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" - } - } - } - if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { - if {$is_multiple} { - set argshow "?${argshow}...?" - } else { - set argshow "?${argshow}?" - } - } else { - if {$is_multiple} { - set argshow "${argshow}..." - } - } - set typeshow [dict get $arginfo -type] - if {$typeshow eq "none"} { - set typeshow "$typeshow $soloflag" - } - if {[dict exists $arginfo -minsize]} { - append typeshow \n "-minsize [dict get $arginfo -minsize]" - } - if {[dict exists $arginfo -maxsize]} { - append typeshow \n "-maxsize [dict get $arginfo -maxsize]" - } - if {[dict exists $arginfo -typeranges]} { - set ranges [dict get $arginfo -typeranges] - if {[llength $ranges] == 1} { - append typeshow \n "-range [lindex [dict get $arginfo -typeranges] 0]" - } else { - append typeshow \n "-ranges" - foreach r $ranges { - append typeshow " {$r}" - } - } - } - - if {$use_table} { - $t add_row [list $argshow $typeshow $default $multiple $help] - if {$arg eq $badarg} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG - } elseif {$arg in $goodargs} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $A_GOODARG - } - } else { - #review - formatting will be all over the shop due to newlines in typesshow, help - set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" - if {$arg eq $badarg} { - set arghelp [punk::ansi::ansiwrap -rawansi $A_BADARG $arghelp] - } elseif {$arg in $goodargs} { - set arghelp [punk::ansi::ansiwrap -rawansi $A_GOODARG $arghelp] - } - foreach ln [split $help \n] { - append arghelp " $ln" \n - } - lappend errlines $arghelp - } - } - - # ------------------------------------------------------------------------------------------------------- - # if the argument class can accept unnamed arguments (or if opts accepts unspecified flags) - display an indication - # ------------------------------------------------------------------------------------------------------- - switch -- $argumentclass { - leaders - values { - if {$argumentclass eq "leaders"} { - set class_unnamed LEADER_UNNAMED - set class_max LEADER_MAX - set class_required LEADER_REQUIRED - set class_directive_defaults LEADERSPEC_DEFAULTS - } else { - set class_unnamed VAL_UNNAMED - set class_max VAL_MAX - set class_required VAL_REQUIRED - set class_directive_defaults VALSPEC_DEFAULTS - } - if {[dict get $form_dict $class_unnamed]} { - set valmax [dict get $form_dict $class_max] - #set valmin [dict get $form_dict VAL_MIN] - if {$valmax eq ""} { - set valmax -1 - } - if {$valmax == -1} { - set possible_unnamed -1 - } else { - set possible_unnamed [expr {$valmax - [llength [dict get $form_dict $class_required]]}] - if {$possible_unnamed < 0} { - set possible_unnamed 0 - } - } - if {$possible_unnamed == -1 || $possible_unnamed > 0} { - #Note 'multiple' is always empty here as each unnamed is assigned to its own positional index - if {$possible_unnamed == 1} { - set argshow ?? - } else { - set argshow ?...? - } - set tp [dict get $form_dict $class_directive_defaults -type] - if {[dict exists $form_dict $class_directive_defaults -default]} { - set default [dict get $form_dict $class_directive_defaults -default] - } else { - set default "" - } - if {$use_table} { - $t add_row [list "$argshow" $tp $default "" ""] - } else { - set arghelp "[a+ bold]$argshow$RST TYPE:$tp DEFAULT:$default\n" - lappend errlines $arghelp - } - } - } - } - opts { - #display row to indicate if -any|-arbitrary true - - #review OPTSPEC_DEFAULTS -multiple ? - if {[dict get $form_dict OPT_ANY]} { - set argshow "?...?" - set tp [dict get $form_dict OPTSPEC_DEFAULTS -type] - if {[dict exists $form_dict OPTSPEC_DEFAULTS -default]} { - set default [dict get $form_dict OPTSPEC_DEFAULTS -default] - } else { - set default "" - } - if {$use_table} { - $t add_row [list "$argshow" $tp $default "" ""] - } else { - set arghelp "[a+ bold]$argshow$RST TYPE:$tp DEFAULT:$default\n" - lappend errlines $arghelp - } - } - } - } - - } ;#end foreach argumentclass - } ;#end is_custom_argdisplay - - if {$use_table} { - $t configure -show_hseps 0\ - -show_header 1\ - -ansibase_body $CLR(ansibase_body)\ - -ansibase_header $CLR(ansibase_header)\ - -ansiborder_header $CLR(ansiborder)\ - -ansiborder_body $CLR(ansiborder) - - $t configure -maxwidth 80 ;#review - if {$returntype ne "tableobject"} { - append errmsg [$t print] - #returntype of table means just the text of the table - $t destroy - } - } else { - append errmsg [join $errlines \n] - } - } errM]} { - append errmsg \n - append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n - append errmsg "$errM" \n - append errmsg "$::errorInfo" - catch {$t destroy} - - } - set arg_error_isrunning 0 - if {$use_table} { - #assert returntype is one of table, tableobject - set result $errmsg ;#default if for some reason table couldn't be used - if {$returntype eq "tableobject"} { - if {[info object isa object $t]} { - set result $t - } - } - } else { - set result $errmsg - } - if {$as_error} { - #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. - #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) - uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] - } else { - return $result - } - } - - - lappend PUNKARGS [list { - @dynamic - @id -id ::punk::args::usage - @cmd -name punk::args::usage -help\ - "Return usage information for a command identified by an id. - - This will only work for commands where a punk::args definition exists - for the command and an id has been defined for it. The id for custom - help for a command should match the fully qualified name of the command. - - Many commands (such as ensembles and oo objects) may have argument - documentation generated dynamically and may not yet have an id. - IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. - - Generally punk::ns::arginfo (aliased as i in the punk shell) should - be used in preference - as it will search for a documentation - mechanism and call punk::args::usage as necessary. - " - -return -default table -choices {string table tableobject} - }\ - {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}}\ - {${[punk::args::resolved_def -types opts ::punk::args::resolved_def -form]}}\ - { - - @values -min 0 -max 1 - id -help\ - "Exact id. - Will usually match the command name" - }] - proc usage {args} { - #lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received - lassign [dict values [punk::args::parse $args withid ::punk::args::usage]] leaders opts values received - set id [dict get $values id] - set real_id [real_id $id] - if {$real_id eq ""} { - error "punk::args::usage - no such id: $id" - } - #-scheme punk_info ?? - arg_error "" [punk::args::get_spec $real_id] {*}$opts -aserror 0 - } - - lappend PUNKARGS [list { - @id -id ::punk::args::get_by_id - @cmd -name punk::args::get_by_id - @values -min 1 - id - arglist -type list -help\ - "list containing arguments to be parsed as per the - argument specification identified by the supplied id." - }] - - - #deprecate? - proc get_by_id {id arglist} { - set definitionlist [punk::args::raw_def $id] - if {[llength $definitionlist] == 0} { - error "punk::args::get_by_id - no such id: $id" - } - #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] - tailcall ::punk::args::get_dict $definitionlist $arglist - } - - #consider - - #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) - #parse ?-flag val?... -- $arglist withid $id - #parse ?-flag val?... -- $arglist withdef $def ?$def?... - - #an experiment.. ideally we'd like arglist at the end? - #parse_withid ?-flag val?.. $id $arglist - #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? - #no possible equivalent for parse_withdef ??? - - lappend PUNKARGS [list { - @id -id ::punk::args::parse - @cmd -name punk::args::parse -help\ - "parse and validate command arguments based on a definition. - - In the 'withid' form the definition is a pre-existing record that has been - created with ::punk::args::define, or indirectly by adding a definition to - the PUNKARGS variable in a namespace which is then registered in - punk::args::register::NAMESPACES, or by a previous call to punk::parse - using 'withdef' and a definition block containing an @id -id directive. - - In the 'withdef' form - the definition is created on the first call and - cached thereafter, if the id didn't already exist. - - form1: parse $arglist ?-flag val?... withid $id - form2: parse $arglist ?-flag val?... withdef $def ?$def? - see punk::args::define - - Returns a dict of information regarding the parsed arguments - example of basic usage for single option only: - punk::args::define { - @id -id ::myns::myfunc - @cmd -name myns::myfunc - @leaders -min 0 -max 0 - @opts - -configfile -type existingfile - #type none makes it a solo flag - -verbose -type none - @values -min 0 -max 0 - } - proc myfunc {args} { - set argd [punk::args::parse $args withid ::myns::myfunc] - lassign [dict values $argd] leaders opts values received solos - if {[dict exists $received] -configfile} { - puts \"have option for existing file [dict get $opts -configfile]\" - } - } - The leaders, opts, values keys in the parse result dict are proper dicts. - The received key is dict-like but can have repeated keys for arguments than can - accept multiples. The value for each received element is the ordinal position. - The solos key refers to a list of solo flags received (those specified with - -type none). This is generally only useful to assist in passing arguments on - to another procedure which also requires solos, because the opts dict contains - solo flags with a 1 value or a list of 1's if it was a solo with -multiple true - specified. - " - @form -form {withid withdef} - @leaders -min 1 -max 1 - arglist -type list -optional 0 -help\ - "Arguments to parse - supplied as a single list" - - @opts - -form -type list -default * -help\ - "Restrict parsing to the set of forms listed. - Forms are the orthogonal sets of arguments a - command can take - usually described in 'synopsis' - entries." - #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance - #todo - configurable per interp/namespace - -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} - - @values -min 2 - - @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" - @values -max 2 - withid -type literal -help\ - "The literal value 'withid'" - id -type string -help\ - "id of punk::args definition for a command" - - - @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" - withdef -type literal -help\ - "The literal value 'withdef'" - - #todo - make -dynamic obsolete - use @dynamic directive instead - def -type string -multiple 1 -optional 0 -help\ - "Each remaining argument is a block of text - defining argument definitions. - As a special case, -dynamic may be - specified as the 1st 2 arguments. These are - treated as an indicator to punk::args about - how to process the definition." - - }] - proc parse {args} { - #puts "punk::args::parse --> '$args'" - set tailtype "" ;#withid|withdef - if {[llength $args] < 3} { - #error "punk::args::parse - invalid call. < 3 args" - punk::args::parse $args withid ::punk::args::parse - } - set opts_and_vals $args - set parseargs [lpop opts_and_vals 0] - - set opts [list] - set values [list] - for {set i 0} {$i < [llength $opts_and_vals]} {incr i} { - if {[string match -* [lindex $opts_and_vals $i]]} { - if {[catch { - lappend opts [lpop opts_and_vals 0] [lpop opts_and_vals 0] - }]} { - #unhappy path - not enough options - #review - which form of punk::args::parse? - punk::args::parse $args withid ::punk::args::parse - } - incr i -1 - #lappend opts $a [lindex $opts_and_vals $i] - } else { - break - } - } - #set values [lrange $opts_and_vals $i end] - set values $opts_and_vals - #puts "---values: $values" - set tailtype [lindex $values 0] - set tailargs [lrange $values 1 end] - - - #set split [lsearch -exact $tailargs withid] - #if {$split < 0} { - # set split [lsearch -exact $tailargs withdef] - # if {$split < 0} { - # #punk::args::usage arg_error? - # #error "punk::args::parse - invalid call. keyword withid|withdef required" - # punk::args::parse $args withid ::punk::args::parse - # } else { - # set tailtype withdef - #} - #} else { - # set tailtype withid - #} - #set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. - - - #if {[llength $opts] % 2} { - #error "punk::args::parse Even number of -flag val pairs required after arglist" - #} - - #Default the -errorstyle to enhanced - # (slowest on unhappy path - but probably clearest for playing with new APIs interactively) - # - application devs should distribute a config file with an errorstyle override if desired. - # - devs who prefer a different default for interactive use should create a config for it. (todo) - set defaultopts [dict create\ - -form {*}\ - -errorstyle enhanced\ - ] - - #todo - load override_errorstyle from configuration - #dict set defaultopts -errorstyle $ - #puts "def: $defaultopts opts: $opts" - set opts [dict merge $defaultopts $opts] - dict for {k v} $opts { - switch -- $k { - -form - -errorstyle { - } - default { - #punk::args::usage $args withid ::punk::args::parse ?? - #error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" - punk::args::parse $args withid ::punk::args::parse - } - } - } - switch -- $tailtype { - withid { - if {[llength $tailargs] != 1} { - #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - punk::args::parse $args withid ::punk::args::parse - } - set id [lindex $tailargs 0] - #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" - #puts stdout "punk::args::parse '$parseargs' withid $id, options: $opts" - set deflist [raw_def $id] - if {[llength $deflist] == 0} { - error "punk::args::parse - no such id: $id" - } - } - withdef { - set deflist $tailargs - if {[llength $deflist] < 1} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" - #puts stdout "punk::args::parse '$parseargs' with [llength $deflist] definition blocks, options: $opts" - } - default { - error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" - } - } - try { - #puts stdout "parse --> get_dict $parseargs -form [dict get $opts -form]" - set result [punk::args::get_dict $deflist $parseargs -form [dict get $opts -form]] - } trap {PUNKARGS VALIDATION} {msg erroropts} { - set opt_errorstyle [dict get $opts -errorstyle] - - #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - - - set ecode [dict get $erroropts -errorcode] - #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... - set msg [string map [list %caller% [Get_caller]] $msg] - switch -- $opt_errorstyle { - minimal { - return -options [list -code error -errorcode $ecode] $msg - } - basic { - #No table layout - unix manpage style - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg -form [dict get $opts -form]] - } - return -options [list -code error -errorcode $ecode] $msg - } - standard { - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] - } - return -options [list -code error -errorcode $ecode] $msg - } - enhanced { - set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below) - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - set ecode_summary [lrange $ecode 0 2] - if {$badarg ne ""} { - lappend ecode_summary -badarg $badarg - } - catch {package require punk::lib} - if {[package provide punk::lib] ne ""} { - append msg \n [punk::lib::showdict -roottype list $estack */*] - } - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] - append msg \n "::errorCode summary: $ecode_summary" - return -options [list -code error -errorcode $ecode] $msg - } else { - #why? todo? - append msg \n "(enhanced error information unavailable)" - append msg \n "::errorCode summary: $ecode_summary" - return -options [list -code error -errorcode $ecode] $msg - } - } - debug { - puts stderr "errorstyle debug not implemented" - return -options [list -code error -errorcode $ecode] $msg - } - default { - puts stderr "errorstyle $opt_errorstyle not recognised: expected one of minimal basic standard enhanced debug" - return -options [list -code error -errorcode $ecode] $msg - } - } - } trap {PUNKARGS} {msg erropts} { - append msg \n "Unexpected PUNKARGS error" - return -options [list -code error -errorcode $ecode] $msg - } trap {} {msg erroropts} { - #review - #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. - #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. - throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] - } - return $result - } - proc parseXXX {args} { - #no solo flags allowed for parse function itself. (ok for arglist being parsed) - set opts [dict create] ;#repeated flags will override earlier. That's ok here. - set arglist {} - set got_arglist 0 - set tailtype "" ;#withid|withdef - set id "" - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {[string match -* $a]} { - dict set opts $a [lindex $args $i+1] - incr i - } else { - set arglist $a - set got_arglist 1 - set tailtype [lindex $args $i+1] - if {$tailtype eq "withid"} { - if {[llength $args] != $i+3} { - error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - } - set id [lindex $args $i+2] - break - } elseif {$tailtype eq "withdef"} { - if {[llength $args] < $i+3} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - set deflist [lrange $args $i+2 end] - break - } else { - error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" - } - } - } - if {!$got_arglist} { - error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." - } - #assert tailtype eq withid|withdef - if {$tailtype eq "withid"} { - #assert $id was provided - return "parse [llength $arglist] args withid $id, options:$opts" - } else { - #assert llength deflist >=1 - return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" - } - #TODO - } - - - #return number of values we can assign to cater for variable length clauses such as {"elseif" expr "?then?" body} - #review - efficiency? each time we call this - we are looking ahead at the same info - proc _get_dict_can_assign_value {idx values nameidx names namesreceived formdict} { - set ARG_INFO [dict get $formdict ARG_INFO] - set all_remaining [lrange $values $idx end] - set thisname [lindex $names $nameidx] - set thistype [dict get $ARG_INFO $thisname -type] - set tailnames [lrange $names $nameidx+1 end] - - #todo - work backwards with any (optional or not) literals at tail that match our values - and remove from assignability. - set ridx 0 - foreach clausename [lreverse $tailnames] { - #puts "=============== clausename:$clausename all_remaining: $all_remaining" - set typelist [dict get $ARG_INFO $clausename -type] - if {[lsearch $typelist literal*] == -1} { - break - } - set max_clause_length [llength $typelist] - if {$max_clause_length == 1} { - #basic case - set alloc_ok 0 - #set v [lindex $values end-$ridx] - set v [lindex $all_remaining end] - set tp [lindex $typelist 0] - #review - ignore ?literal? and ?literal(xxx)? when clause-length == 1? (should raise error during definition instead? - #we shouldn't have an optional clause member if there is only one member - the whole name should be marked -optional true instead. - set tp [string trim $tp ?] - foreach tp_member [split $tp |] { - if {[string match literal* $tp]} { - set litinfo [string range $tp 7 end] ;#get bracketed part if of form literal(xxx) - if {[string match (*) $litinfo]} { - set match [string range $litinfo 1 end-1] - } else { - #plain "literal" without bracketed specifier - match to argument name - set match $clausename - } - if {$v eq $match} { - set alloc_ok 1 - lpop all_remaining - if {![dict get $ARG_INFO $clausename -multiple]} { - lpop tailnames - } - #type (or one of the possible type alternates) matched a literal - break - } - } - } - if {!$alloc_ok} { - if {![dict get $ARG_INFO $clausename -optional]} { - break - } - } - - } else { - #review - we assume here that we don't have a set of clause-members where all are marked optional (?membertype?) - #This is better caught during definition. - #e.g rn = {elseif expr (?then?) body} typelist = {literal expr ?literal? script} - #set cvals [lrange $values end-$ridx end-[expr {$ridx + $max_clause_length-1}]] - set cvals [lrange $values end-[expr {$ridx + $max_clause_length-1}] end-$ridx] - set rcvals [lreverse $cvals] - set alloc_count 0 - #clause name may have more entries than types - extras at beginning are ignored - set rtypelist [lreverse $typelist] - set rclausename [lrange [lreverse $clausename] 0 [llength $typelist]-1] - #assert length of rtypelist >= $rclausename - set alloc_ok 0 - set reverse_type_index 0 - #todo handle type-alternates - # for example: -type {string literal(x)|literal(y)} - foreach tp $rtypelist membername $rclausename { - #(membername may be empty if not enough elements) - #set rv [lindex $rcvals end-$alloc_count] - set rv [lindex $all_remaining end-$alloc_count] - if {[string match {\?*\?} $tp]} { - set clause_member_optional 1 - } else { - set clause_member_optional 0 - } - set tp [string trim $tp ?] - if {[string match literal* $tp]} { - set litinfo [string range $tp 7 end] - if {[string match (*) $litinfo]} { - set match [string range $litinfo 1 end-1] - } else { - #if membername empty - equivalent to "literal()" - matches empty string literal - #edgecase - possibly? no need for empty-string literals - but allow it without error. - set match $membername - } - #todo -literalprefix - if {$rv eq $match} { - set alloc_ok 1 ;#we need at least one literal-match to set alloc_ok - incr alloc_count - } else { - if {$clause_member_optional} { - # - } else { - set alloc_ok 0 - break - } - } - } else { - if {$clause_member_optional} { - #review - optional non-literal makes things harder.. - #we don't want to do full type checking here - but we now risk allocating an item that should actually - #be allocated to the previous value - set prev_type [lindex $rtypelist $reverse_type_index+1] - if {[string match literal* $prev_type]} { - set litinfo [string range $prev_type 7 end] - #todo -literalprefix - if {[string match (*) $litinfo]} { - set match [string range $litinfo 1 end-1] - } else { - #prev membername - set match [lindex $rclausename $reverse_type_index+1] - } - if {$rv ne $match} { - #current val doesn't match previous type - allocate here - incr alloc_count - } - } else { - #no literal to anchor against.. - incr alloc_count - } - } else { - #allocate regardless of type - we're only matching on arity and literal positioning here. - #leave final type-checking for later. - incr alloc_count - } - } - incr reverse_type_index - } - if {$alloc_ok && $alloc_count > 0} { - #set n [expr {$alloc_count -1}] - #set all_remaining [lrange $all_remaining end-$n end] - set all_remaining [lrange $all_remaining 0 end-$alloc_count] - #don't lpop if -multiple true - if {![dict get $ARG_INFO $clausename -multiple]} { - lpop tailnames - } - } else { - break - } - } - incr ridx - } - set num_remaining [llength $all_remaining] - - if {[dict get $ARG_INFO $thisname -optional] || ([dict get $ARG_INFO $thisname -multiple] && $thisname in $namesreceived)} { - #todo - check -multiple for required min/max (not implemented: make -multiple accept ?) - #thisname already satisfied, or not required - set tail_needs 0 - foreach t $tailnames { - if {![dict get $ARG_INFO $t -optional]} { - set min_clause_length [llength [lsearch -all -not [dict get $ARG_INFO $t -type] {\?*\?}]] - incr tail_needs $min_clause_length - } - } - set all_remaining [lrange $all_remaining 0 end-$tail_needs] - } - - #thistype - set alloc_ok 1 ;#default assumption only - set alloc_count 0 - set resultlist [list] - set n [expr {[llength $thistype]-1}] - #name can have more or less items than typelist - set thisnametail [lrange $thisname end-$n end] - set tpidx 0 - set newtypelist $thistype - foreach tp $thistype membername $thisnametail { - set v [lindex $all_remaining $alloc_count] - if {[string match {\?*\?} $tp]} { - set clause_member_optional 1 - } else { - set clause_member_optional 0 - } - set tp [string trim $tp ?] - - set member_satisfied 0 - - #----------------------------------------------------------------------------------- - #first build list of any literals - and whether any are literalprefix - set literals [list] - set literalprefixes [list] - set nonliterals [list] - set dict_member_match [dict create] - foreach tp_member [split $tp |] { - #JJJJ - if {[string match literal* $tp_member]} { - if {[string match literalprefix* $tp_member]} { - set litinfo [string range $tp_member 13 end] - if {[string match (*) $litinfo]} { - lappend literalprefixes [string range $litinfo 1 end-1] - } else { - lappend literalprefixes $membername - } - dict set dict_member_match $tp_member [lindex $literalprefixes end] - } else { - set litinfo [string range $tp_member 7 end] - if {[string match (*) $litinfo]} { - lappend literals [string range $litinfo 1 end-1] - } else { - lappend literals $membername - } - dict set dict_member_match $tp_member [lindex $literals end] - } - } else { - lappend nonliterals $tp_member - } - } - #----------------------------------------------------------------------------------- - #asert - each tp_member is a key in dict_member_match - if {[llength $nonliterals] > 0} { - #presence of any ordinary type as one of the alternates - means we consider it a match - #we don't validate here -leave validation for later (review) - set member_satisfied 1 - } else { - if {$v in $literals} { - set member_satisfied 1 - } else { - #literals is included in the prefix-calc - but a shortened version of an entry in literals is not allowed - #(exact match would have been caught in other branch of this if) - set full_v [tcl::prefix::match -error "" [list {*}$literals {*}$literalprefixes] $v] - if {$full_v ne "" && $full_v ni $literals} { - #matched prefix must be for one of the entries in literalprefixes - valid - set member_satisfied 1 - } - } - } - - #foreach tp_member [split $tp |] { - # if {[string match literal* $tp_member]} { - # #todo - support literal prefix-matching - # #e.g see ::readFile filename ?text|binary? - must accept something like readfile xxx.txt b - # set litinfo [string range $tp_member 7 end] - # if {[string match (*) $litinfo]} { - # set match [string range $litinfo 1 end-1] - # } else { - # set match $membername - # } - # set match [dict get $dict_member_match $tp_member] - # if {$v eq $match} { - # set member_satisfied 1 - # break - # } - # } else { - # #we don't validate here -leave validation for later (review) - # set member_satisfied 1 - # break - # } - #} - - if {$member_satisfied} { - if {$clause_member_optional && $alloc_count >= [llength $all_remaining]} { - if {[dict exists $ARG_INFO $thisname -typedefaults]} { - set d [lindex [dict get $ARG_INFO $thisname -typedefaults] $tpidx] - lappend resultlist $d - lset newtypelist $tpidx ?defaulted-$tp? - } else { - lset newtypelist $tpidx ?omitted-$tp? - lappend resultlist "" - } - } else { - lappend resultlist $v - incr alloc_count - } - } else { - if {$clause_member_optional} { - if {[dict exists $ARG_INFO $thisname -typedefaults]} { - set d [lindex [dict get $ARG_INFO $thisname -typedefaults] $tpidx] - lappend resultlist $d - lset newtypelist $tpidx ?defaulted-$tp? - } else { - lappend resultlist "" - lset newtypelist $tpidx ?omitted-$tp? - } - } else { - set alloc_ok 0 - } - } - - if {$alloc_count > [llength $all_remaining]} { - set alloc_ok 0 - break - } - incr tpidx - } - - #?omitted-*? and ?defaulted-*? in typelist are a way to know which elements in the clause were missing/defaulted - #so that they are not subject to type validation - #such elements shouldn't be subject to validation - if {$alloc_ok} { - set d [dict create consumed $alloc_count resultlist $resultlist typelist $newtypelist] - } else { - set d [dict create consumed 0 resultlist {} typelist $thistype] - } - #puts ">>>> _get_dict_can_assign_value $d" - return $d - } - - #todo? - a version of get_dict that directly supports punk::lib::tstr templating - #rename get_dict - # - - #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 get_dict {deflist rawargs args} { - #see arg_error regarding considerations around unhappy-path performance - - if {[llength $args] % 2 != 0} { - error "punk::args::get_dict args must be a dict of option value pairs" - } - set defaults [dict create\ - -form *\ - ] - set opts [dict merge $defaults $args] - dict for {k v} $opts { - switch -- $k { - -form {} - default { - error "punk::args::get_dict Unexpected option '$k' Known options -form" - } - } - } - - - #*** !doctools - #[call [fun get_dict] [arg deflist] [arg rawargs] [arg args]] - #[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 values - #[para]ARGUMENTS: - #[list_begin arguments] - #[arg_def list-of-multiline-string deflist] - #[para] These are blocks 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 defining a flag 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 etc - #[para]Each optionspec line defining a positional argument is of the form: - #[para]argumentname -key val -ky2 val2... - #[para]where the valid keys for each option specification are: -default -type -range -choices - #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value - #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. - #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. - #[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, - #but it could be a manually constructed list of values made for example from positional args defined in the proc. - #[list_end] - #[para] - - #consider line-processing example below for which we need info complete to determine record boundaries - #punk::args::get_dict [list { - # @opts - # -opt1 -default {} - # -opt2 -default { - # etc - # } - # @values -multiple 1 - #}] $args - - - - - #rawargs: args values to be parsed - #we take a definition list rather than resolved argspecs - because the definition could be dynamic - - #if definition has been seen before, - #define will either return a permanently cached argspecs (-dynamic 0) - or - # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. - set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]] - - # ----------------------------------------------- - # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) - tcl::dict::with argspecs {} ;#turn keys into vars - #e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info,id_info,form_names - # ----------------------------------------------- - set opt_form [dict get $opts -form] - if {$opt_form eq "*"} { - set selected_forms $form_names - } elseif {[string is integer -strict $opt_form]} { - if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { - error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set selected_forms [list [lindex $form_names $opt_form]] - } else { - if {$opt_form ni $form_names} { - error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set selected_forms [list $opt_form] - } - - - #puts "-arg_info->$arg_info" - set flagsreceived [list] ;#for checking if required flags satisfied - set solosreceived [list] - set multisreceived [list] - #secondary purpose: - #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 ? - - # -- --- --- --- - # Handle leading positionals - # todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ? - - #todo - handle multiple fids? - set fid [lindex $selected_forms 0] - set formdict [dict get $FORMS $fid] - tcl::dict::with formdict {} - #populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc - if {$VAL_MIN eq ""} { - set valmin 0 - #set VAL_MIN 0 - foreach v $VAL_NAMES { - if {![dict get $ARG_INFO $v -optional]} { - # todo variable clause lengths (items marked optional in types using leading&trailing questionmarks) - # e.g -types {a ?xxx?} - #this has one required and one optional - set typelist [dict get $ARG_INFO $v -type] - set clause_length 0 - foreach t $typelist { - if {![string match {\?*\?} $t]} { - incr clause_length - } - } - incr valmin $clause_length - } - } - } else { - set valmin $VAL_MIN - } - - set pre_values {} - - set argnames [tcl::dict::keys $ARG_INFO] - #set optnames [lsearch -all -inline $argnames -*] - #JJJ - set all_opts [list] - set lookup_optset [dict create] - foreach optset $OPT_NAMES { - #optset e.g {-x|--longopt|--longopt=|--otherlongopt} - set optmembers [split $optset |] - foreach optdef $optmembers { - set opt [string trimright $optdef =] - if {$opt ni $all_opts} { - dict set lookup_optset $opt $optset - lappend all_opts $opt - } - } - } - set ridx 0 - set rawargs_copy $rawargs - set remaining_rawargs $rawargs - set leader_posn_name "" - set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) - set is_multiple 0 ;#last leader may be multi - - - #consider for example: LEADER_NAMES {"k v" leader2 leader3} with -type {int number} & -type {int int int} & -type string - #(i.e clause-length of 2 3 and 1) - #This will take 6 raw leaders to fill in the basic case that all are -optional 0 and -multiple 0 - #REVIEW - what about optional members in leaders e.g -type {int ?double?} - set named_leader_args_max 0 - foreach ln $LEADER_NAMES { - set typelist [dict get $ARG_INFO $ln -type] - incr named_leader_args_max [llength $typelist] - } - - #set id [dict get $argspecs id] - #if {$id eq "::if"} { - #puts stderr "::if" - #puts stderr "get_dict--> remaining_rawargs: $remaining_rawargs" - #} - - - #REVIEW - this attempt to classify leaders vs opts vs values doesn't account for leaders with clauses containing optional elements - #e.g @leadrs {x -type {int ?int?}} - set nameidx 0 - if {$LEADER_MAX != 0} { - for {set ridx 0} {$ridx < [llength $rawargs]} {incr ridx} { - set raw [lindex $rawargs $ridx] ;#received raw arg - if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { - break - } - if {[llength $LEADER_NAMES] && $nameidx == [llength $LEADER_NAMES]-1} { - #at last named leader - set leader_posn_name [lindex $LEADER_NAMES $nameidx] - if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { - set is_multiple 1 - } - } elseif {$ridx > $named_leader_args_max-1} { - #beyond names - retain name if -multiple was true - if {!$is_multiple} { - set leader_posn_name "" - } - } else { - set leader_posn_name [lindex $LEADER_NAMES $nameidx] ;#may return empty string - } - if {$OPT_MAX ne "0"} { - #all_opts includes end_of_opts marker -- if configured - no need to explicitly check for it separately - set flagname $raw - if {[string match --* $raw]} { - set eposn [string first = $raw] - # --flag=xxx - if {$eposn >=3} { - set flagname [string range $raw 0 $eposn-1] - } - } - set matchopt [::tcl::prefix::match -error {} $all_opts $flagname] - if {$matchopt ne ""} { - #flaglike matches a known flag - don't treat as leader - break - } - } - - #for each branch - break or lappend - if {$leader_posn_name ne ""} { - set leader_type [dict get $ARG_INFO $leader_posn_name -type] - #todo - variable clauselengths e.g 'if' command which has optional 'then' and 'else' "noise words" - set clauselength [llength $leader_type] - set min_clauselength 0 - foreach t $leader_type { - if {![string match {\?*\?} $t]} { - incr min_clauselength - } - } - if {$leader_posn_name ni $LEADER_REQUIRED} { - #optional leader - - #most adhoc arg processing will allocate based on number of args rather than matching choice values first - #(because a choice value could be a legitimate data value) - - #review - option to process in this manner? - #first check if the optional leader value is a match for a choice ? - #if {[dict exists $arg_info $leader_posn_name -choices]} { - # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] $raw] - # if {$vmatch ne ""} { - # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values - # lappend pre_values [lpop remaining_rawargs 0] - # incr ridx - # continue - # } - #} - if {[llength $remaining_rawargs] < $min_clauselength} { - #not enough remaining args to fill even this optional leader - #rather than raise error here - perform our break (for end of leaders) and let the code below handle it - break - } - - #check if enough remaining_rawargs to fill any required values - if {$valmin > 0 && [llength $remaining_rawargs] - $min_clauselength < $valmin} { - break - } - - #leadername may be a 'clause' of arbitrary length (e.g -type {int double} or {int string number}) - set end_leaders 0 - foreach t $leader_type { - set raw [lindex $rawargs $ridx] - if {[string match {\?*\?} $t] && [string match -* $raw]} { - #review - limitation of optional leaders is they can't be same value as any defined flags/opts - set flagname $raw - if {[string match --* $raw]} { - set eposn [string first = $raw] - # --flag=xxx - if {$eposn >=3} { - set flagname [string range $raw 0 $eposn-1] - } - } - set matchopt [::tcl::prefix::match -error {} $all_opts $flagname] - if {$matchopt ne ""} { - #don't consume if flaglike (and actually matches an opt) - set end_leaders 1 - break ;#break out of looking at -type members in the clause - } else { - #unrecognised flag - treat as value for optional member of the clause - lappend pre_values [lpop remaining_rawargs 0] - incr ridx - } - } else { - lappend pre_values [lpop remaining_rawargs 0] - incr ridx - } - } - incr ridx -1 ;#leave ridx at index of last r that we set - if {$end_leaders} { - break - } - if {!$is_multiple} { - incr nameidx - } - dict incr leader_posn_names_assigned $leader_posn_name - } else { - #clause is required - if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { - #already accepted at least one complete clause for this name - requirement satisfied - now equivalent to optional - if {[llength $remaining_rawargs] < $min_clauselength} { - #not enough remaining args to fill even this optional leader - #rather than raise error here - perform our break (for end of leaders) and let the code below handle it - break - } - - if {$valmin > 0 && [llength $remaining_rawargs] - $min_clauselength < $valmin} { - break - } - } - #if we didn't break - requirement is not yet satisfied, or is satisfied but still enough remaining_rawargs for required values - #we still need to check if enough values for the leader itself - if {[llength $remaining_rawargs] < $min_clauselength} { - #not enough remaining args to fill *required* leader - break - } - - set end_leaders 0 - foreach t $leader_type { - set raw [lindex $rawargs $ridx] - if {[string match {\?*\?} $t] && [string match -* $raw]} { - #review - limitation of optional leaders is they can't be same value as any defined flags/opts - - set matchopt [::tcl::prefix::match -error {} $all_opts $raw] - if {$matchopt ne ""} { - #don't consume if flaglike (and actually matches an opt) - set end_leaders 1 - break ;#break out of looking at -type members in the clause - } else { - #unrecognised flag - treat as value for optional member of the clause - lappend pre_values [lpop remaining_rawargs 0] - incr ridx - } - } else { - lappend pre_values [lpop remaining_rawargs 0] - incr ridx - } - } - incr ridx -1 - if {$end_leaders} { - break - } - if {!$is_multiple} { - incr nameidx - } - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #unnamed leader - if {$LEADER_MIN ne "" } { - if {$ridx > $LEADER_MIN-1} { - if {$LEADER_MAX ne "" && $ridx == $LEADER_MAX} { - break - } else { - if {$valmin > 0} { - if {[llength $remaining_rawargs] > $valmin} { - lappend pre_values [lpop remaining_rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } else { - break - } - } else { - lappend pre_values [lpop remaining_rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } - } else { - #haven't reached LEADER_MIN - lappend pre_values [lpop remaining_rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #review - if is_multiple, keep going if enough remaining_rawargs for values? - break - } - } - - #incr ridx - } ;# end foreach r $rawargs_copy - } - #puts "get_dict ================> pre: $pre_values" - - set argstate $ARG_INFO ;#argstate may have entries added - set arg_checks $ARG_CHECKS - - if {$LEADER_MIN eq ""} { - set leadermin 0 - } else { - set leadermin $LEADER_MIN - } - if {$LEADER_MAX eq ""} { - set leadermax -1 - } else { - set leadermax $LEADER_MAX - } - - if {$VAL_MAX eq ""} { - set valmax -1 - } else { - set valmax $VAL_MAX - } - - #assert leadermax leadermin are numeric - #assert - remaining_rawargs has been reduced by leading positionals - - set opts [dict create] ;#don't set to OPT_DEFAULTS here - #set id [dict get $argspecs id] - #if {$id eq "::if"} { - #puts stderr "::if" - #puts stderr "get_dict--> pre_values: $pre_values" - #puts stderr "get_dict--> remaining_rawargs: $remaining_rawargs" - #} - - set leaders [list] - set arglist {} - set post_values {} - #valmin, valmax - #puts stderr "remaining_rawargs: $remaining_rawargs" - #puts stderr "argstate: $argstate" - if {$OPT_MAX ne "0" && [lsearch $remaining_rawargs -*] >= 0} { - #contains at least one possible flag - set maxidx [expr {[llength $remaining_rawargs] -1}] - if {$valmax == -1} { - set vals_total_possible [llength $remaining_rawargs] - set vals_remaining_possible $vals_total_possible - } else { - set vals_total_possible $valmax - set vals_remaining_possible $vals_total_possible - } - for {set i 0} {$i <= $maxidx} {incr i} { - set remaining_args_including_this [expr {[llength $remaining_rawargs] - $i}] - #lowest valmin is 0 - if {$remaining_args_including_this <= $valmin} { - # if current arg is -- it will pass through as a value here - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - break - } - set a [lindex $remaining_rawargs $i] - #if {$a eq "--"} { - # #REVIEW - # #remaining num args <= valmin already covered above - # if {$valmax != -1} { - # #finite max number of vals - # if {$remaining_args_including_this == $valmax} { - # #assume it's a value. - # set arglist [lrange $remaining_rawargs 0 $i-1] - # set post_values [lrange $remaining_rawargs $i end] - # } else { - # #assume it's an end-of-options marker - # lappend flagsreceived -- - # set arglist [lrange $remaining_rawargs 0 $i] - # set post_values [lrange $remaining_rawargs $i+1 end] - # } - # } else { - # #unlimited number of post_values accepted - # #treat this as eopts - we don't care if remainder look like options or not - # lappend flagsreceived -- - # set arglist [lrange $remaining_rawargs 0 $i] - # set post_values [lrange $remaining_rawargs $i+1 end] - # } - # break - #} - if {[string match --* $a]} { - if {$a eq "--"} { - if {$a in $OPT_NAMES} { - #treat this as eopts - we don't care if remainder look like options or not - lappend flagsreceived -- - set arglist [lrange $remaining_rawargs 0 $i] - set post_values [lrange $remaining_rawargs $i+1 end] - } else { - #assume it's a value. - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - } - break - } else { - set eposn [string first = $a] - if {$eposn > 2} { - #only allow longopt-style = for double leading dash longopts - #--*= usage - if {$flagname ni $raw_optionset_members} { - # - set msg "Bad options for %caller%. Option $optionset at index [expr {$i-1}] requires a value, but '$flagname' not specified in definition to allow space-separated value." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list badoptionformat $optionset index [expr {$i-1}]] -badarg $optionset -argspecs $argspecs]] $msg - } - } - if {$solo_only} { - #same logic as 'solo' branch below for -type none - if {[tcl::dict::get $argstate $optionset -multiple]} { - if {$api_opt ni $flagsreceived} { - #override any default - don't lappend to it - tcl::dict::set opts $api_opt 1 - } else { - tcl::dict::lappend opts $api_opt 1 - } - if {$api_opt ni $multisreceived} { - lappend multisreceived $api_opt - } - } else { - tcl::dict::set opts $api_opt 1 - } - incr vals_remaining_possible -1 - lappend solosreceived $api_opt ;#dups ok - } else { - #check if it was actually a value that looked like a flag - if {$i == $maxidx} { - #if no optvalue following - assume it's a value - #(caller should probably have used -- before it) - #review - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - break - } - #flagval comes from next remaining rawarg - set flagval [lindex $remaining_rawargs $i+1] - if {[tcl::dict::get $argstate $optionset -multiple]} { - #don't lappend to default - we need to replace if there is a default - if {$api_opt ni $flagsreceived} { - tcl::dict::set opts $api_opt [list $flagval] - } else { - tcl::dict::lappend opts $api_opt $flagval - } - if {$api_opt ni $multisreceived} { - lappend multisreceived $api_opt - } - } else { - tcl::dict::set opts $api_opt $flagval - } - #incr i to skip flagval - incr vals_remaining_possible -2 - if {[incr i] > $maxidx} { - set msg "Bad options for %caller%. No value supplied for last option $optionset at index [expr {$i-1}] which is not marked with -type none" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $optionset index [expr {$i-1}]] -badarg $optionset -argspecs $argspecs]] $msg - } - } - } - } else { - #solo - if {[tcl::dict::get $argstate $optionset -multiple]} { - if {$api_opt ni $flagsreceived} { - #override any default - don't lappend to it - tcl::dict::set opts $api_opt 1 - } else { - tcl::dict::lappend opts $api_opt 1 - } - if {$api_opt ni $multisreceived} { - lappend multisreceived $api_opt - } - } else { - tcl::dict::set opts $api_opt 1 - } - incr vals_remaining_possible -1 - lappend solosreceived $api_opt ;#dups ok - } - lappend flagsreceived $api_opt ;#dups ok - } else { - #starts with - but unmatched option flag - #comparison to valmin already done above - if {$valmax ne -1 && $remaining_args_including_this <= $valmax} { - #todo - look at optspec_default and see if solo/vs opt-val pair - #we may need to lookahead by 2 regarding valmax valmin - - #even if optany - assume an unknown within the space of possible values is a value - #unmatched option in right position to be considered a value - treat like eopts - #review - document that an unspecified arg within range of possible values will act like eopts -- - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - break - } - if {!([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { - if {$OPT_ANY} { - #exlude argument with whitespace from being a possible option e.g dict - #todo - passthrough of unrecognised --longopt=xxx without looking for following flag-value - set eposn [string first = $a] - if {[string match --* $a] && $eposn > 2} { - #only allow longopt-style = for double leading dash longopts - #--*= $maxidx} { - set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg - #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a - } - incr vals_remaining_possible -2 - } else { - #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none - if {[tcl::dict::get $argstate $a -multiple]} { - if {![tcl::dict::exists $opts $a]} { - tcl::dict::set opts $a 1 - } else { - tcl::dict::lappend opts $a 1 - } - if {$a ni $multisreceived} { - lappend multisreceived $a - } - } else { - tcl::dict::set opts $a 1 - } - incr vals_remaining_possible -1 - lappend solosreceived $a - } - } - - lappend flagsreceived $flagreceived ;#adhoc flag name (if --x=1 -> --x) - } else { - if {[llength $OPT_NAMES]} { - set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES (3)" - } else { - set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any|-arbitrary false" - } - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg - #arg_error $errmsg $argspecs -badarg $optionset - } - } else { - #not a flag/option - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - break - } - } - - } - #set values [list {*}$pre_values {*}$post_values] - set leaders $pre_values - set values $post_values - } else { - set leaders $pre_values - set values $remaining_rawargs - #set values [list {*}$pre_values {*}$remaining_rawargs] ;#no -flags detected - set arglist [list] - } - #set id [dict get $argspecs id] - #if {$id eq "::if"} { - #puts stderr "::if" - #puts stderr "get_dict--> arglist: $arglist" - #puts stderr "get_dict--> leaders: $leaders" - #puts stderr "get_dict--> values: $values" - #} - - #--------------------------------------- - set ordered_opts [dict create] - set unaliased_opts [lmap v $OPT_NAMES {string trimright [lindex [split $v |] end] =}] - #unaliased_opts is list of 'api_opt' (to handle flag aliases of form -a1|-a2|-api_opt) - # e.g -fg|-foreground - # e.g -x|--fullname= - #Resulting unaliased_opts from list {-fg|-foreground -x|--fullname=} should be {-foreground --fullname} - foreach o $unaliased_opts optset $OPT_NAMES { - if {[dict exists $opts $o]} { - dict set ordered_opts $o [dict get $opts $o] - } elseif {[dict exists $OPT_DEFAULTS $optset]} { - dict set ordered_opts $o [dict get $OPT_DEFAULTS $optset] - } - } - #add in possible arbitrary opts after the defined opts, due to @opts directive flag '-any|-arbitrary true' - dict for {o oval} $opts { - if {![dict exists $ordered_opts $o]} { - dict set ordered_opts $o $oval - } - } - set opts $ordered_opts - #--------------------------------------- - - - set positionalidx 0 ;#index for unnamed positionals (both leaders and values) - set leadername_multiple "" - set leadernames_received [list] - - set num_leaders [llength $leaders] - - #---------------------------------------- - #Establish firm leaders ordering - set leaders_dict [dict create] - foreach lname [lrange $LEADER_NAMES 0 $num_leaders-1] { - dict set leaders_dict $lname {} - } - set leaders_dict [dict merge $leaders_dict $LEADER_DEFAULTS] - #---------------------------------------- - - set start_position $positionalidx - set nameidx 0 - #MAINTENANCE - (*nearly*?) same loop logic as for value - for {set ldridx 0} {$ldridx < [llength $leaders]} {incr ldridx} { - set leadername [lindex $LEADER_NAMES $nameidx] - set ldr [lindex $leaders $ldridx] - if {$leadername ne ""} { - set leadertypelist [tcl::dict::get $argstate $leadername -type] - - set assign_d [_get_dict_can_assign_value $ldridx $leaders $nameidx $LEADER_NAMES $leadernames_received $formdict] - set consumed [dict get $assign_d consumed] - set resultlist [dict get $assign_d resultlist] - set newtypelist [dict get $assign_d typelist] - if {[tcl::dict::get $argstate $leadername -optional]} { - if {$consumed == 0} { - #error 111 - incr ldridx -1 - set leadername_multiple "" - incr nameidx - continue - } - } else { - #required named arg - if {$consumed == 0} { - if {$leadername ni $leadernames_received} { - #puts stderr "_get_dict_can_assign_value $ldridx $values $nameidx $VAL_NAMES" - set msg "Bad number of leaders for %caller%. Not enough remaining values to assign to required arguments (fail on $leadername)." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingrequiredleader $leadername ] -argspecs $argspecs]] $msg - } else { - #error 222 - incr ldridx -1 - set leadername_multiple "" - incr nameidx - continue - } - } - } - - if {[llength $leadertypelist] == 1} { - set clauseval $ldr - } else { - set clauseval $resultlist - incr ldridx [expr {$consumed - 1}] - tcl::dict::set argstate $leadername -type $newtypelist ;#(possible ?omitted-? and ?defaulted-? entries - } - - if {[tcl::dict::get $argstate $leadername -multiple]} { - #if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { - # #current stored ldr equals defined default - don't include default in the list we build up - # tcl::dict::set leaders_dict $leadername [list $clauseval] ;#important to treat first element as a list - #} else { - # tcl::dict::lappend leaders_dict $leadername $clauseval - #} - if {$leadername in $leadernames_received} { - tcl::dict::lappend leaders_dict $leadername $clauseval - } else { - tcl::dict::set leaders_dict $leadername [list $clauseval] - } - set leadername_multiple $leadername - } else { - tcl::dict::set leaders_dict $leadername $clauseval - set leadername_multiple "" - incr nameidx - } - lappend leadernames_received $leadername - } else { - if {$leadername_multiple ne ""} { - set leadertypelist [tcl::dict::get $argstate $leadername_multiple -type] - if {[llength $leadertypelist] == 1} { - set clauseval $ldr - } else { - set clauseval [list] - incr ldridx -1 - foreach t $leadertypelist { - incr ldridx - if {$ldridx > [llength $leaders]-1} { - set msg "Bad number of leaders for %caller%. Received [llength $clauseval] values ('$clauseval') for '$leadername_multiple', but requires up to [llength $leadertypelist] values." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength [llength $leadertypelist] ] -argspecs $argspecs]] $msg - } - lappend clauseval [lindex $leaders $ldridx] - } - } - tcl::dict::lappend leaders_dict $leadername_multiple $clauseval - #name already seen - but must add to leadernames_received anyway (as with opts and values) - lappend leadernames_received $leadername_multiple - } else { - if {$LEADER_UNNAMED} { - tcl::dict::set leaders_dict $positionalidx $ldr - tcl::dict::set argstate $positionalidx $LEADERSPEC_DEFAULTS - tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS - lappend leadernames_received $positionalidx - } else { - set msg "Bad number of leaders for %caller%. Received more leaders than can be assigned to argument names. (set '@leaders -unnamed true' to allow unnamed leaders)" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list toomanyarguments [llength $values] index $positionalidx] -argspecs $argspecs]] $msg - } - } - } - set positionalidx [expr {$start_position + $ldridx + 1}] - } - #----------------------------------------------------- - #satisfy test parse_withdef_leaders_no_phantom_default - foreach leadername [dict keys $leaders_dict] { - if {[string is integer -strict $leadername]} { - #ignore leadername that is a positionalidx - #review - always trailing - could use break? - continue - } - if {$leadername ni $leadernames_received && ![dict exists $LEADER_DEFAULTS $leadername]} { - #remove the name with empty-string default we used to establish fixed order of names - #The 'leaders' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default. - dict unset leaders_dict $leadername - } - } - #----------------------------------------------------- - - set validx 0 - set valname_multiple "" - set valnames_received [list] - - set num_values [llength $values] - #------------------------------------------ - #Establish firm values ordering - ## Don't set values_dict to VAL_DEFAULTS - or order of values_dict will be intermittently wrong based on whether values have defaults - ## set values_dict $val_defaults - set values_dict [dict create] - foreach valname [lrange $VAL_NAMES 0 $num_values-1] { - #set ALL valnames to lock in positioning - #note - later we need to unset any optional that had no default and was not received (no phantom default) - dict set values_dict $valname {} - } - set values_dict [dict merge $values_dict $VAL_DEFAULTS] - #------------------------------------------ - set nameidx 0 - set start_position $positionalidx - #MAINTENANCE - (*nearly*?) same loop logic as for leaders - for {set validx 0} {$validx < [llength $values]} {incr validx} { - set valname [lindex $VAL_NAMES $nameidx] - set val [lindex $values $validx] - if {$valname ne ""} { - set valtypelist [tcl::dict::get $argstate $valname -type] - - set assign_d [_get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES $valnames_received $formdict] - set consumed [dict get $assign_d consumed] - set resultlist [dict get $assign_d resultlist] - set newtypelist [dict get $assign_d typelist] - if {[tcl::dict::get $argstate $valname -optional]} { - if {$consumed == 0} { - incr validx -1 - set valname_multiple "" - incr nameidx - continue - } - } else { - #required named arg - if {$consumed == 0} { - if {$valname ni $valnames_received} { - #puts stderr "_get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES" - set msg "Bad number of values for %caller%. Not enough remaining values to assign to required arguments (fail on $valname)." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingrequiredvalue $valname ] -argspecs $argspecs]] $msg - } else { - incr validx -1 - set valname_multiple "" - incr nameidx - continue - } - } - } - #assert can_assign != 0, we have at least one value to assign to clause - - if {[llength $valtypelist] == 1} { - set clauseval $val - } else { - #clauseval must contain as many elements as the max length of -types! - #(empty-string/default for optional (?xxx?) clause members) - set clauseval $resultlist - #_get_dict_can_assign has only validated clause-length and literals match - #we assign and leave further validation for main validation loop. - incr validx [expr {$consumed -1}] - if {$validx > [llength $values]-1} { - error "get_dict unreachable" - set msg "Bad number of values for %caller%. Received [llength $clauseval] values for clause '$valname', but requires up to [llength $valtypelist] values." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength [llength $valtypelist] ] -argspecs $argspecs]] $msg - } - - tcl::dict::set argstate $valname -type $newtypelist ;#(possible ?omitted-? and ?defaulted-? entries - } - - if {[tcl::dict::get $argstate $valname -multiple]} { - #if {[tcl::dict::exists $VAL_DEFAULTS $valname]} { - # #current stored val equals defined default - don't include default in the list we build up - # tcl::dict::set values_dict $valname [list $clauseval] ;#important to treat first element as a list - #} else { - # tcl::dict::lappend values_dict $valname $clauseval - #} - if {$valname in $valnames_received} { - tcl::dict::lappend values_dict $valname $clauseval - } else { - tcl::dict::set values_dict $valname [list $clauseval] - } - set valname_multiple $valname - } else { - tcl::dict::set values_dict $valname $clauseval - set valname_multiple "" - incr nameidx - } - lappend valnames_received $valname - } else { - if {$valname_multiple ne ""} { - set valtypelist [tcl::dict::get $argstate $valname_multiple -type] - if {[llength $valname_multiple] == 1} { - set clauseval $val - } else { - set clauseval [list] - incr validx -1 - for {set i 0} {$i < [llength $valtypelist]} {incr i} { - incr validx - if {$validx > [llength $values]-1} { - set msg "Bad number of values for %caller%. Received [llength $clauseval] values for clause '$valname_multiple', but requires [llength $valtypelist] values." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength [llength $valtypelist] ] -argspecs $argspecs]] $msg - } - lappend clauseval [lindex $values $validx] - } - } - tcl::dict::lappend values_dict $valname_multiple $clauseval - #name already seen - but must add to valnames_received anyway (as with opts and leaders) - lappend valnames_received $valname_multiple - } else { - if {$VAL_UNNAMED} { - tcl::dict::set values_dict $positionalidx $val - tcl::dict::set argstate $positionalidx $VALSPEC_DEFAULTS - tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS - lappend valnames_received $positionalidx - } else { - set msg "Bad number of values for %caller%. Received more values than can be assigned to argument names. (set '@values -unnamed true' to allow unnamed values)" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list toomanyarguments [llength $values] index $positionalidx] -argspecs $argspecs]] $msg - } - } - } - set positionalidx [expr {$start_position + $validx + 1}] - } - #----------------------------------------------------- - #satisfy test parse_withdef_values_no_phantom_default - foreach vname [dict keys $values_dict] { - if {[string is integer -strict $vname]} { - #ignore vname that is a positionalidx - #review - always trailing - could break? - continue - } - if {$vname ni $valnames_received && ![dict exists $VAL_DEFAULTS $vname]} { - #remove the name with empty-string default we used to establish fixed order of names - #The 'values' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default. - dict unset values_dict $vname - } - } - #----------------------------------------------------- - - if {$leadermax == -1} { - #only check min - if {$num_leaders < $leadermin} { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected at least $leadermin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - } - } else { - if {$num_leaders < $leadermin || $num_leaders > $leadermax} { - if {$leadermin == $leadermax} { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected exactly $leadermin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - } else { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - } - } - } - - if {$valmax == -1} { - #only check min - if {$num_values < $valmin} { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $valmin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg - } - } else { - if {$num_values < $valmin || $num_values > $valmax} { - if {$valmin == $valmax} { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $valmin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg - } else { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $valmin and $valmax inclusive" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg - } - } - } - - #assertion - opts keys are full-length option names if -any|-arbitrary was false or if the supplied option as a shortname matched one of our defined options - - - #opts explicitly marked as -optional 0 must be present - regardless of -any|-arbitrary (which allows us to ignore additional opts to pass on to next call) - #however - if -any|-arbitrary 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 SHOULD? 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 - - #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? - #example timing difference: - #struct::set difference {x} {a b} - #normal interp 0.18 u2 vs safe interp 9.4us - #if {[llength [set missing [struct::set difference $OPT_REQUIRED $flagsreceived]]]} { - # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" - #} - #if {[llength [set missing [struct::set difference $VAL_REQUIRED $valnames_received]]]} { - # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" - #} - #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us - if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { - set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadermissing $missing received $leadernames_received] -argspecs $argspecs]] $msg - #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - set api_opt_required [lmap v $OPT_REQUIRED {lindex [split $v |] end}] - if {[llength [set missing [punklib_ldiff $api_opt_required $flagsreceived]]]} { - set full_missing [dict get $lookup_optset $missing] - set msg "Required option missing for %caller%. missing flags: '$full_missing' are marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list optionmissing $full_missing received $flagsreceived] -argspecs $argspecs]] $msg - #arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs - } - if {[llength [set missing [punklib_ldiff $VAL_REQUIRED $valnames_received]]]} { - set msg "Required value missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list valuemissing $missing received $valnames_received] -argspecs $argspecs]] $msg - #arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - - #--------------------------------------------------------------------------------------------- - #maintain order of opts $opts values $values as caller may use lassign. - set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] - if {[llength $receivednames]} { - #flat zip of names with overall posn, including opts - #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] - set i -1 - set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] - } else { - set received_posns [list] - } - #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) - #(e.g using 'dict exists $received -flag') - # - but it can have duplicate keys when args/opts have -multiple 1 - #It is actually a list of paired elements - #--------------------------------------------------------------------------------------------- - - - #todo - truncate/summarize values in error messages - - #todo - allow defaults outside of choices/ranges - - #check types,ranges,choices - set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] - #set combined_defaults [tcl::dict::merge $VAL_DEFAULTS $OPT_DEFAULTS] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash - #puts "---opts_and_values:$opts_and_values" - #puts "---argstate:$argstate" - tcl::dict::for {api_argname value_group} $opts_and_values { - if {[string match -* $api_argname]} { - #get full option name such as -fg|-foreground from non-alias name such as -foreground - #if "@opts -any|-arbitrary true" - we may have an option that wasn't defined - if {[dict exists $lookup_optset $api_argname]} { - set argname [dict get $lookup_optset $api_argname] - } else { - puts stderr "unable to find $api_argname in $lookup_optset" - } - } else { - set argname $api_argname - } - - set thisarg [tcl::dict::get $argstate $argname] - #set thisarg_keys [tcl::dict::keys $thisarg] - set thisarg_checks [tcl::dict::get $arg_checks $argname] - set is_multiple [tcl::dict::get $thisarg -multiple] - set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] - set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] - set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] - set has_default [tcl::dict::exists $thisarg -default] - if {$has_default} { - set defaultval [tcl::dict::get $thisarg -default] - } - set typelist [tcl::dict::get $thisarg -type] - set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] - set regexprepass [tcl::dict::get $thisarg -regexprepass] - set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 - set validationtransform [tcl::dict::get $thisarg -validationtransform] - - - #JJJJ - if {$is_multiple} { - set vlist $value_group - } else { - set vlist [list $value_group] - } - #JJJJ - if {[llength $typelist] == 1} { - set vlist [list $vlist] - } - set vlist_original $vlist ;#retain for possible final strip_ansi - - #review - validationtransform - if {$is_validate_ansistripped} { - #validate_ansistripped 1 - package require punk::ansi - set vlist_check [list] - foreach clause_value $vlist { - lappend vlist_check [punk::ansi::ansistrip $clause_value] - } - } else { - #validate_ansistripped 0 - set vlist_check $vlist - } - - switch -- [Dict_getdef $thisarg -ARGTYPE unknown] { - leader { - set dname leaders_dict - set argclass "Leading argument" - } - option { - set dname opts - set argclass Option - } - value { - set dname values_dict - set argclass "Trailing argument" - } - default { - set dname "_unknown_" ;#NA - set argclass "Unknown argument" - } - } - #reduce our validation requirements by removing values which match defaultval or match -choices - #(could be -multiple with -choicerestricted 0 where some selections match and others don't) - if {$api_argname in $receivednames && $has_choices} { - #-choices must also work with -multiple - #todo -choicelabels - set choiceprefix [tcl::dict::get $thisarg -choiceprefix] - set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] - set choiceprefixreservelist [Dict_getdef $thisarg -choiceprefixreservelist {}] - set choicerestricted [tcl::dict::get $thisarg -choicerestricted] - set choicemultiple [tcl::dict::get $thisarg -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set nocase [tcl::dict::get $thisarg -nocase] - set choices [Dict_getdef $thisarg -choices {}] - set choicegroups [Dict_getdef $thisarg -choicegroups {}] - set allchoices $choices - if {[dict size $choicegroups]} { - dict for {groupname groupmembers} $choicegroups { - lappend allchoices {*}$groupmembers - } - } - #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups - #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes - - - set idx 0 ;# - #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes - #assert llength $vlist == llength [dict get $dname $argname] - # (unless there was a default and the option wasn't specified) - set vlist_validate [list] - set vlist_check_validate [list] - foreach e $vlist e_check $vlist_check { - set allchoices_in_list 0 - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - #vlist and vlist_check can be list of lists if -multiple and -choicemultiple - #each e represents 0 or more choice selections - set c_list $e - set c_check_list $e_check - #todo? check if entire list matches default? - } else { - #only one choice at a time - ensure single entry in c_list c_check_list - set c_list [list $e] - set c_check_list [list $e_check] - } - - - #----------------------------------- - #fast fail on the wrong number of choices - if {[llength $c_list] < $choicemultiple_min} { - set msg "$argclass $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { - set msg "$argclass $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - #----------------------------------- - - set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list - foreach c $c_list c_check $c_check_list { - if {$nocase} { - set casemsg " (case insensitive)" - set choices_test [tcl::string::tolower $allchoices] - #Don't lcase the denylist - even in nocase mode! - #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] - set v_test [tcl::string::tolower $c_check] - } else { - set casemsg " (case sensitive)" - set v_test $c_check - set choices_test $allchoices - } - set choice_in_list 0 - set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? - if {!$matches_default} { - if {$choiceprefix} { - #can we handle empty string as a choice? It should just work - REVIEW/test - set choice_exact_match 0 - if {$c_check in $allchoices} { - #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing - set chosen $c_check - set choice_in_list 1 - set choice_exact_match 1 - } elseif {$v_test in $choices_test} { - #assert - if we're here, nocase must be true - #we know choice is present as full-length match except for case - #now we want to select the case from the choice list - not the supplied value - #we don't set choice_exact_match - because we will need to override the optimistic existing val below - #review - foreach avail [lsort -unique $allchoices] { - if {[string match -nocase $c $avail]} { - set chosen $avail - } - } - #assert chosen will always get set - set choice_in_list 1 - } else { - #puts ">>>> choiceprefixreservelist: $choiceprefixreservelist" - #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. - #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. - #in this block we can treat empty result from prefix match as a non-match - if {$nocase} { - #nocase implies that our entered value doesn't have to match case of choices - - #but we would still like to select the best match if there are case-dups. - #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete - # selecting Del will find Delete, del will match delete (and raise error) - # but DEL will also match delete rather than Delete - so again an error is raised. - #This is counterintuitive with -nocase - #This is probably such an edge case that best served with documentation as a feature-not-bug - #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? - #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. - - set bestmatch [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check] - if {$bestmatch eq "" || $bestmatch in $choiceprefixreservelist} { - set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $choices_test] {*}$choiceprefixreservelist] $v_test] - #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing - set chosen [lsearch -inline -nocase $allchoices $chosen] - set choice_in_list [expr {$chosen ne ""}] - } else { - set chosen $bestmatch - set choice_in_list 1 - } - } else { - set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check] - if {$chosen eq "" || $chosen in $choiceprefixreservelist} { - set choice_in_list 0 - } else { - set choice_in_list 1 - } - } - #override choice_in_list if in deny list - #don't allow prefixing for elements from -choiceprefixdenylist - #we still use all elements to calculate the prefixes though - #review - case difference edge cases in choiceprefixdenylist !todo - if {$chosen in $choiceprefixdenylist} { - set choice_in_list 0 - set chosen "" - } - } - - #override the optimistic existing val - if {$choice_in_list && !$choice_exact_match} { - if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { - if {$is_multiple} { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $idx $chosen - tcl::dict::set $dname $argname $existing - } else { - tcl::dict::set $dname $argname $chosen - } - } else { - if {$is_multiple} { - set existing_all [tcl::dict::get [set $dname] $argname] - lset existing_all $idx $choice_idx $chosen - tcl::dict::set $dname $argname $existing_all - } else { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $choice_idx $chosen - tcl::dict::set $dname $argname $existing - } - } - } - } else { - #value as stored in $dname is ok - set choice_in_list [expr {$v_test in $choices_test}] - } - } - - if {!$choice_in_list && !$matches_default} { - if {!$choicerestricted} { - #if {$is_multiple} { - # set existing [tcl::dict::get [set $dname] $argname] - # lset existing $idx $v_test - # tcl::dict::set $dname $argname $existing - #} else { - # tcl::dict::set $dname $argname $v_test - #} - lappend vlist_validate $c - lappend vlist_check_validate $c_check - } else { - #unhappy path - if {$choiceprefix} { - set prefixmsg " (or a unique prefix of a value)" - } else { - set prefixmsg "" - } - #review: $c vs $c_check for -badval? - set msg "$argclass '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname - } - } - incr choice_idx - } - - incr idx - } - #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation - #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - - #todo - don't add to validation lists if not in receivednames - #if we have an optionset such as "-f|-x|-etc" api_argname is -etc - if {$api_argname ni $receivednames} { - set vlist [list] - set vlist_check_validate [list] - } else { - if {[llength $vlist] && $has_default} { - #defaultval here is a value for the clause. - set vlist_validate [list] - set vlist_check_validate [list] - foreach clause_value $vlist clause_check $vlist_check { - #JJJJ - #argname - #thisarg - set tp [dict get $thisarg -type] - if {[llength $tp] == 1} { - if {$clause_value ni $vlist_validate} { - #for -choicemultiple with default that could be a list use 'ni' ?? review - if {[lindex $clause_check 0] ne $defaultval} { - lappend vlist_validate $clause_value - lappend vlist_check_validate $clause_check - } - } - } else { - if {$clause_value ni $vlist_validate} { - if {$clause_check ne $defaultval} { - lappend vlist_validate $clause_value - lappend vlist_check_validate $clause_check - } - } - } - #Todo? - #else ??? - } - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - } - - #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups - #assert: our vlist & vlist_check lists have been reduced to remove those - if {[llength $vlist] && !$is_allow_ansi} { - #allow_ansi 0 - package require punk::ansi - #do not run ta::detect on a list - foreach clause_value $vlist { - foreach e $clause_value { - if {[punk::ansi::ta::detect $e]} { - set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - #puts "argname:$argname v:$v is_default:$is_default" - #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. - #arguments that are at their default are not subject to type and other checks - - #don't validate defaults or choices that matched - #puts "---> opts_and_values: $opts_and_values" - #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" - #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} - - #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups - #assert [llength $vlist] == [llength $vlist_check] - if {[llength $vlist]} { - for {set t 0} {$t < [llength $typelist]} {incr t} { - set typespec [lindex $typelist $t] - set type [string trim $typespec ?] - #puts "$argname - switch on type: $type" - switch -- $type { - any {} - literal { - foreach clause_value $vlist { - set e [lindex $clause_value $t] - if {$e ne $argname} { - set msg "$argclass '$argname' for %caller% requires literal value '$argname'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - } - } - } - list { - foreach clause_value $vlist_check { - set e_check [lindex $clause_value $t] - if {![tcl::string::is list -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[llength $e_check] < $checkval} { - set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[llength $e_check] > $checkval} { - set msg "$argclass '$argname for %caller% requires list with -maxsize $checkval. Received len:[llength $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - } - indexexpression { - foreach clause_value $vlist_check { - set e_check [lindex $clause_value $t] - if {[catch {lindex {} $e_check}]} { - set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - string - ansistring - globstring { - #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string - #we possibly don't want to always have to regex on things that don't pass the other more basic checks - # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) - # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) - # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead - # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function - # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) - # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail - - #todo? - way to validate both unstripped and stripped? - set pass_quick_list_e [list] - set pass_quick_list_e_check [list] - set remaining_e $vlist - set remaining_e_check $vlist_check - #review - order of -regexprepass and -regexprefail in original rawargs significant? - #for now -regexprepass always takes precedence - if {$regexprepass ne ""} { - foreach clauseval $vlist clauseval_check $vlist_check { - set e [lindex $clauseval $t] - set e_check [lindex $clauseval_check $t] - if {[regexp [lindex $regexprepass $t] $e]} { - lappend pass_quick_list_e $clauseval - lappend pass_quick_list_e_check $clauseval_check - } - } - set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] - set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] - } - if {$regexprefail ne ""} { - foreach clauseval $remaining_e clauseval_check $remaining_e_check { - set e [lindex $clauseval $t] - set e_check [lindex $clauseval_check $t] - #puts "----> checking $e vs regex $regexprefail" - if {[regexp $regexprefail $e]} { - if {[tcl::dict::exists $thisarg -regexprefailmsg]} { - #review - %caller% ?? - set msg [tcl::dict::get $thisarg -regexprefailmsg] - } else { - set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" - } - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - switch -- $type { - ansistring { - #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi - #.. so we need to look at the original values in $vlist not $vlist_check - - #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? - #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? - package require punk::ansi - foreach clauseval $remaining_e { - set e [lindex $clauseval $t] - if {![punk::ansi::ta::detect $e]} { - set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - globstring { - foreach clauseval $remaining_e { - set e [lindex $clauseval $t] - if {![regexp {[*?\[\]]} $e]} { - set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - - if {[tcl::dict::size $thisarg_checks]} { - foreach clauseval $remaining_e_check { - set e_check [lindex $clauseval $t] - if {[dict exists $thisarg_checks -minsize]} { - set minsize [dict get $thisarg_checks -minsize] - # -1 for disable is as good as zero - if {[tcl::string::length $e_check] < $minsize} { - set msg "$argclass '$argname' for %caller% requires string with -minsize $minsize. Received len:[tcl::string::length $e_check] value:'$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - if {[dict exists $thisarg_checks -maxsize]} { - set maxsize [dict get $thisarg_checks -maxsize] - if {$checkval ne "-1"} { - if {[tcl::string::length $e_check] > $maxsize} { - set msg "$argclass '$argname' for %caller% requires string with -maxsize $maxsize. Received len:[tcl::string::length $e_check] value:'$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - } - number { - #review - consider effects of Nan and Inf - #NaN can be considered as 'technically' a number (or at least a special numeric value) - foreach clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} { - set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - if {[tcl::dict::exists $thisarg -typeranges]} { - set ranges [tcl::dict::get $thisarg -typeranges] - foreach clauseval $vlist clauseval_check $vlist_check { - set e [lindex $clauseval $t] - set e_check [lindex $clauseval_check $t] - set range [lindex $ranges $t] - lassign {} low high ;#set both empty - lassign $range low high - - if {"$low$high" ne ""} { - if {[::tcl::mathfunc::isnan $e]} { - set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - if {$low eq ""} { - if {$e_check > $high} { - set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } elseif {$high eq ""} { - if {$e_check < $low} { - set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } else { - if {$e_check < $low || $e_check > $high} { - set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - } - int { - #elements in -typeranges can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive - foreach clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - if {[tcl::dict::exists $thisarg -typeranges]} { - set ranges [tcl::dict::get $thisarg -typeranges] - foreach clauseval $vlist clauseval_check $vlist_check { - set e [lindex $clauseval $t] - set e_check [lindex $clauseval_check $t] - set range [lindex $ranges $t] - lassign $range low high - if {"$low$high" ne ""} { - if {$low eq ""} { - #lowside unspecified - check only high - if {$e_check > $high} { - set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } elseif {$high eq ""} { - #highside unspecified - check only low - if {$e_check < $low} { - set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } else { - #high and low specified - if {$e_check < $low || $e_check > $high} { - set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - } - double { - foreach clauseval $vlist clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - if {![tcl::string::is double -strict $e_check]} { - set e [lindex $clauseval $t] - set msg "$argclass $argname for %caller% requires type double. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - if {[tcl::dict::size $thisarg_checks]} { - if {[dict exists $thisarg_checks -typeranges]} { - set ranges [dict get $thisarg_checks -typeranges] - foreach clauseval $vlist clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - set range [lindex $ranges $t] - #todo - small-value double comparisons with error-margin? review - #todo - empty string for low or high - lassign $range low high - if {$e_check < $low || $e_check > $high} { - set e [lindex $clauseval $t] - set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - bool { - foreach clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - if {![tcl::string::is boolean -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - dict { - foreach clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - if {[llength $e_check] %2 != 0} { - set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - } - if {[tcl::dict::size $thisarg_checks]} { - if {[dict exists $thisarg_checks -minsize]} { - set minsizes [dict get $thisarg_checks -minsize] - foreach clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - set minsize [lindex $minsizes $t] - # -1 for disable is as good as zero - if {[tcl::dict::size $e_check] < $minsize} { - set msg "$argclass '$argname' for %caller% requires dict with -minsize $minsize. Received dict size:[dict size $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - } - } - if {[dict exists $thisarg_checks -maxsize]} { - set maxsizes [dict get $thisarg_checks -maxsize] - foreach clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - set maxsize [lindex $maxsizes $t] - if {$maxsize ne "-1"} { - if {[tcl::dict::size $e_check] > $maxsize} { - set msg "$argclass '$argname' for %caller% requires dict with -maxsize $maxsize. Received dict size:[dict size $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - } - } - } - } - } - alnum - - alpha - - ascii - - control - - digit - - graph - - lower - - print - - punct - - space - - upper - - wordchar - - xdigit { - foreach clauseval $vlist clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - if {![tcl::string::is $type -strict $e_check]} { - set e [lindex $clauseval $t] - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - file - - directory - - existingfile - - existingdirectory { - foreach e $vlist e_check $vlist_check { - #//review - we may need '?' char on windows - if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { - #what about special file names e.g on windows NUL ? - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - if {$type eq "existingfile"} { - foreach e $vlist e_check $vlist_check { - if {![file exists $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } elseif {$type eq "existingdirectory"} { - foreach e $vlist e_check $vlist_check { - if {![file isdirectory $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } - } - char { - #review - char vs unicode codepoint vs grapheme? - foreach clauseval $vlist clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - if {[tcl::string::length $e_check] != 1} { - set e [lindex $clauseval $t] - set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } - } - - } - - - } - - if {$is_strip_ansi} { - set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach - if {[tcl::dict::get $thisarg -multiple]} { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict $argname $stripped_list - } - option { - tcl::dict::set opts $argname $stripped_list - } - value { - tcl::dict::set values_dict $argname $stripped_list - } - } - } else { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict [lindex $stripped_list 0] - } - option { - tcl::dict::set opts $argname [lindex $stripped_list 0] - } - value { - tcl::dict::set values_dict [lindex $stripped_list 0] - } - } - } - } - } - - return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived multis $multisreceived] - } - - - proc forms {id} { - set spec [get_spec $id] - if {[dict size $spec]} { - return [dict get $spec form_names] - } else { - return [list] - } - } - lappend PUNKARGS [list { - @id -id ::punk::args::synopsis - @cmd -name punk::args::synopsis -help\ - "Return synopsis for each form of a command id - on separate lines. - If -form is given, supply only - the synopsis for that form. - " - @opts - -form -type string -default * - -return -type string -default full -choices {full summary dict} - @values -min 1 -max -1 - cmditem -multiple 1 -optional 0 - }] - proc synopsis {args} { - set argd [punk::args::parse $args withid ::punk::args::synopsis] - - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - if {$has_punkansi} { - set I [punk::ansi::a+ italic] - set NI [punk::ansi::a+ noitalic] - #set RST [punk::ansi::a] - set RST "\x1b\[m" - } else { - set I "" - set NI "" - set RST "" - } - - ##set form * - ##if {[lindex $args 0] eq "-form"} { - ## set arglist [lrange $args 2 end] - ## set form [lindex $args 1] - ##} else { - ## set arglist $args - ##} - ##if {[llength $arglist] == 0} { - ## error "punk::args::synopsis expected command id possibly with trailing subcommands/args" - ##} - ##set id [lindex $arglist 0] - ##set cmdargs [lrange $arglist 1 end] - - lassign [dict values $argd] leaders opts values - set form [dict get $opts -form] - set opt_return [dict get $opts -return] - set cmditems [dict get $values cmditem] - set id [lindex $cmditems 0] - set cmdargs [lrange $cmditems 1 end] - - - set spec [get_spec $id] - if {$spec eq ""} { - return - } - set form_names [dict get $spec form_names] - if {$form ne "*"} { - if {[string is integer -strict $form]} { - set f [lindex $form_names $form] - if {$f ne ""} { - set form_names [list $f] - } else { - set form_names [list] - } - } else { - if {$form in $form_names} { - set form_names [list $form] - } else { - set form_names [list] - } - } - } - - set SYND [dict create] - set syn "" - #todo - -multiple etc - foreach f $form_names { - set SYNLIST [list] - dict set SYND $f [list] - append syn "$id" - set forminfo [dict get $spec FORMS $f] - #foreach argname [dict get $forminfo LEADER_NAMES] { - # set arginfo [dict get $forminfo ARG_INFO $argname] - # set ARGD [dict create argname $argname class leader] - # if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - # set display [lindex [dict get $arginfo -choices] 0] - # } elseif {[dict get $arginfo -type] eq "literal"} { - # set display $argname - # } else { - # set display $I$argname$RST - # } - # if {[dict get $arginfo -optional]} { - # append syn " ?$display?" - # } else { - # append syn " $display" - # } - # dict set ARGD type [dict get $arginfo -type] - # dict set ARGD optional [dict get $arginfo -optional] - # dict set ARGD display $display - # dict lappend SYND $f $ARGD - #} - foreach argname [dict get $forminfo LEADER_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set typelist [dict get $arginfo -type] - if {[llength $typelist] == 1} { - set tp [lindex $typelist 0] - if {[dict exists $arginfo -typesynopsis]} { - #set arg_display [dict get $arginfo -typesynopsis] - set clause [dict get $arginfo -typesynopsis] - } else { - #set arg_display $argname - if {$tp eq "literal"} { - set clause [lindex $argname end] - } elseif {[string match literal(*) $tp]} { - set match [string range $tp 8 end-1] - set clause $match - } else { - set clause $I$argname$NI - } - } - } else { - set n [expr {[llength $typelist]-1}] - set name_tail [lrange $argname end-$n end];#if there are enough tail words in the argname to match -types - set clause "" - if {[dict exists $arginfo -typesynopsis]} { - set tp_displaylist [dict get $arginfo -typesynopsis] - } else { - set tp_displaylist [lrepeat [llength $typelist] ""] - } - - foreach typespec $typelist td $tp_displaylist elementname $name_tail { - #elementname will commonly be empty - if {[string match {\?*\?} $typespec]} { - set tp [string range $typespec 1 end-1] - set member_optional 1 - } else { - set tp $typespec - set member_optional 0 - } - if {$tp eq "literal"} { - set c $elementname - } elseif {[string match literal(*) $tp]} { - set match [string range $tp 8 end-1] - set c $match - } else { - if {$td eq ""} { - set c $I$tp$NI - } else { - set c $td - } - } - if {$member_optional} { - append clause " " "(?$c?)" - } else { - append clause " " $c - } - } - set clause [string trimleft $clause] - } - - set ARGD [dict create argname $argname class leader] - if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} { - if {[dict get $arginfo -multiple]} { - #set display "?$I$argname$NI?..." - set display "?$clause?..." - } else { - set display "?$clause?" - #if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - # set display "?[lindex [dict get $arginfo -choices] 0]?" - #} elseif {[dict get $arginfo -type] eq "literal"} { - # set display "?$argname?" - #} else { - # set display "?$I$argname$NI?" - #} - } - } else { - if {[dict get $arginfo -multiple]} { - #set display "$I$argname$NI ?$I$argname$NI?..." - set display "$clause ?$clause?..." - } else { - set display $clause - #if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - # set display "[lindex [dict get $arginfo -choices] 0]" - #} elseif {[dict get $arginfo -type] eq "literal"} { - # set display $argname - #} else { - # set display "$I$argname$NI" - #} - } - } - append syn " $display" - dict set ARGD type [dict get $arginfo -type] - dict set ARGD optional [dict get $arginfo -optional] - dict set ARGD display $display - dict lappend SYND $f $ARGD - } - foreach argname [dict get $forminfo OPT_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set ARGD [dict create argname $argname class option] - set tp [dict get $arginfo -type] - if {[dict exists $arginfo -typesynopsis]} { - set tp_display [dict get $arginfo -typesynopsis] - } else { - #set tp_display "<$tp>" - set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first) - foreach tp_member [split $tp |] { - #-type literal not valid for opt - review - if {[string match literal(*) $tp_member]} { - set match [string range $tp_member 8 end-1] - lappend alternates $match - } elseif {[string match literalprefix(*) $tp_member]} { - set match [string range $tp_member 14 end-1] - lappend alternates $match - } else { - lappend alternates $I<$tp_member>$NI - } - } - #todo - trie prefixes display? - set alternates [punk::args::lib::lunique $alternates] - set tp_display [join $alternates |] - } - - if {[dict get $arginfo -optional]} { - if {[dict get $arginfo -multiple]} { - if {$tp eq "none"} { - set display "?$argname?..." - } else { - set display "?$argname $tp_display?..." - } - } else { - if {$tp eq "none"} { - set display "?$argname?" - } else { - set display "?$argname $tp_display?" - } - } - } else { - if {[dict get $arginfo -multiple]} { - if {$tp eq "none"} { - set display "$argname ?$argname...?" - } else { - set display "$argname $tp_display ?$argname $tp_display?..." - } - } else { - if {$tp eq "none"} { - set display $argname - } else { - set display "$argname $tp_display" - } - } - } - append syn " $display" - dict set ARGD type [dict get $arginfo -type] - dict set ARGD optional [dict get $arginfo -optional] - dict set ARGD display $display - dict lappend SYND $f $ARGD - } - foreach argname [dict get $forminfo VAL_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set typelist [dict get $arginfo -type] - if {[llength $typelist] == 1} { - set tp [lindex $typelist 0] - if {[dict exists $arginfo -typesynopsis]} { - #set arg_display [dict get $arginfo -typesynopsis] - set clause [dict get $arginfo -typesynopsis] - } else { - #set arg_display $argname - set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first) - foreach tp_member [split $tp |] { - if {$tp_member eq "literal"} { - lappend alternates [lindex $argname end] - } elseif {[string match literal(*) $tp_member]} { - set match [string range $tp_member 8 end-1] - lappend alternates $match - } elseif {[string match literalprefix(*) $tp_member]} { - set match [string range $tp_member 14 end-1] - lappend alternates $match - } else { - lappend alternates $I$argname$NI - } - } - #remove dupes - but keep order (e.g of dupes -type string|int when no -typesynopsis was specified) - #todo - trie prefixes display - set alternates [punk::args::lib::lunique $alternates] - set clause [join $alternates |] - } - } else { - set n [expr {[llength $typelist]-1}] - set name_tail [lrange $argname end-$n end];#if there are enough tail words in the argname to match -types - set clause "" - if {[dict exists $arginfo -typesynopsis]} { - set tp_displaylist [dict get $arginfo -typesynopsis] - } else { - set tp_displaylist [lrepeat [llength $typelist] ""] - } - - foreach typespec $typelist td $tp_displaylist elementname $name_tail { - #elementname will commonly be empty - if {[string match {\?*\?} $typespec]} { - set tp [string range $typespec 1 end-1] - set member_optional 1 - } else { - set tp $typespec - set member_optional 0 - } - #handle alternate-types e.g literal(text)|literal(binary) - set alternates [list] - foreach tp_member [split $tp |] { - if {$tp_member eq "literal"} { - lappend alternates $elementname - } elseif {[string match literal(*) $tp_member]} { - set match [string range $tp_member 8 end-1] - lappend alternates $match - } elseif {[string match literalprefix(*) $tp_member]} { - set match [string range $tp_member 14 end-1] - lappend alternates $match - } else { - if {$td eq ""} { - lappend alternates $I$tp$NI - } else { - lappend alternates $td - } - } - } - set alternates [punk::args::lib::lunique $alternates] - set c [join $alternates |] - if {$member_optional} { - append clause " " "(?$c?)" - } else { - append clause " " $c - } - } - set clause [string trimleft $clause] - } - - set ARGD [dict create argname $argname class value] - if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} { - if {[dict get $arginfo -multiple]} { - #set display "?$I$argname$NI?..." - set display "?$clause?..." - } else { - set display "?$clause?" - #if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - # set display "?[lindex [dict get $arginfo -choices] 0]?" - #} elseif {[dict get $arginfo -type] eq "literal"} { - # set display "?$argname?" - #} else { - # set display "?$I$argname$NI?" - #} - } - } else { - if {[dict get $arginfo -multiple]} { - #set display "$I$argname$NI ?$I$argname$NI?..." - set display "$clause ?$clause?..." - } else { - set display $clause - #if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - # set display "[lindex [dict get $arginfo -choices] 0]" - #} elseif {[dict get $arginfo -type] eq "literal"} { - # set display $argname - #} else { - # set display "$I$argname$NI" - #} - } - } - append syn " $display" - dict set ARGD type [dict get $arginfo -type] - dict set ARGD optional [dict get $arginfo -optional] - dict set ARGD display $display - dict lappend SYND $f $ARGD - } - append syn \n - } - switch -- $opt_return { - full { - return [string trim $syn \n] - } - summary { - set summary "" - showdict $SYND - dict for {form arglist} $SYND { - append summary $id - set class_state leader - set option_count 0 - set value_count 0 - foreach ainfo $arglist { - switch -- [dict get $ainfo class] { - leader { - append summary " [dict get $ainfo display]" - } - option { - incr option_count - } - value { - incr value_count - if {$class_state ne "value"} { - if {$option_count > 0} { - append summary " ?options ($option_count defined)?" - } - set class_state value - } - append summary " [dict get $ainfo display]" - } - } - } - if {$value_count == 0 && $option_count > 0} { - append summary " ?options ($option_count defined)?" - } - append summary \n - } - set summary [string trim $summary \n] - return $summary - } - dict { - return $SYND - } - } - } - - - lappend PUNKARGS [list { - @id -id ::punk::args::synopsis_summary - @cmd -name punk::args::synopsis_summary -help\ - "Reduce the width of a synopsis string - by coalescing options to ?options?... - synopsis string may be arbitrarily marked - up with ANSI codes." - @opts - @values -min 1 -max -1 - synopsis -multiple 0 -optional 0 - }] - proc synopsis_summary {args} { - set argd [punk::args::parse $args withid ::punk::args::synopsis_summary] - set synopsis [dict get $argd values synopsis] - set summary "" - foreach sline [split $synopsis \n] { - set sline [regsub -all {\s+} $sline " "] ;#normalize to single spacing only - review - set in_opt 0 - set line_out "" - set codestack [list] - set parts [punk::ansi::ta::split_codes_single $sline] - #basic - foreach {pt code} $parts { - set charlist [split $pt ""] - for {set i 0} {$i < [llength $charlist]} {incr i} { - set c [lindex $charlist $i] - - switch -- $c { - ? { - if {!$in_opt} { - set in_opt 1 - } else { - - } - } - " " { - if {!$in_opt} { - append line_out " " - } else { - set in_opt - } - } - default { - if {!$in_opt} { - append line_out $c - } - } - } - } - if {$code ne ""} { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set codestack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set codestack [list $code] - } elseif {[punk::ansi::codetype::is_sgr $code]} { - #basic simplification first - remove straight dupes - set dup_posns [lsearch -all -exact $codestack $code] ;#must be -exact because of square-bracket glob chars - set codestack [lremove $codestack {*}$dup_posns] - lappend codestack $code - } else { - #? ignore other ANSI codes? - } - } - } - if {[string match -* $plain_s] || [string match ?- $plain_s]} { - } - } - return $summary - } - - lappend PUNKARGS [list { - @id -id ::punk::args::TEST - @opts -optional 0 - -o1 -default 111 -help "opt 1 mandatory" - @opts -optional 1 - -o2 -default 222 -help "opt 2 optional" - @values -min 0 -max 1 - v -help\ - "v1 optional" - }] - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::lib { - variable PUNKARGS - tcl::namespace::export * - tcl::namespace::path [list [tcl::namespace::parent]] - #*** !doctools - #[subsection {Namespace punk::args::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 flatzip {l1 l2} { - concat {*}[lmap a $l1 b $l2 {list $a $b}] - } - - if {[info commands lseq] ne ""} { - #tcl 8.7+ lseq significantly faster, especially for larger ranges - #The internal rep can be an 'arithseries' with no string representation - proc zero_based_posns {count} { - if {$count < 1} {return} - lseq 0 $count-1 - } - } else { - proc zero_based_posns {count} { - if {$count < 1} {return} - lsearch -all [lrepeat $count 0] * - } - } - - #return list of single column-width marks - possibly with ansi - proc choiceinfo_marks {choice choiceinfodict} { - set marks [list] - if {[dict exists $choiceinfodict $choice]} { - set cinfo [dict get $choiceinfodict $choice] - foreach info $cinfo { - if {[lindex $info 0] eq "doctype"} { - switch -- [lindex $info 1] { - punkargs { - lappend marks [punk::ns::Cmark punkargs brightgreen] - } - ensemble { - lappend marks [punk::ns::Cmark ensemble brightyellow] - } - oo { - lappend marks [punk::ns::Cmark oo brightcyan] - } - ooc { - lappend marks [punk::ns::Cmark ooc cyan] - } - ooo { - lappend marks [punk::ns::Cmark ooo cyan] - } - native { - lappend marks [punk::ns::Cmark native] - } - unknown { - lappend marks [punk::ns::Cmark unknown brightred] - } - } - } - } - } - return $marks - } - - - #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 -1] in calling scope ${[lindex [set x] 0]} !} - lappend PUNKARGS [list { - @id -id ::punk::args::lib::tstr - @cmd -name punk::args::lib::tstr -help\ - "A rough equivalent of js template literals - - Substitutions: - \$\{$varName\} - \$\{[myCommand]\} - (when -allowcommands flag is given)" - -allowcommands -default 0 -type none -help\ - "If -allowcommands is present, placeholder can contain commands - e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" - -undent -default 1 -type boolean -help\ - "undent/dedent the template lines. - The longest common prefix of whitespace is removed" - -indent -default "" -type string -help\ - "String with which to indent the template - prior to substitution. - If -undent is enabled, that is performed - first, then the indent is applied." - -paramindents -default line -choices {none line position} -choicelabels { - line\ - " Use leading whitespace in - the line in which the - placeholder occurs." - position\ - " Use the position in - the line in which the - placeholder occurs." - none\ - " No indents applied to - subsequent placeholder value - lines. This will usually - result in text awkwardly - ragged unless the source code - has also been aligned with the - left margin or the value has - been manually padded." - } -help\ - "How indenting is done for subsequent lines in a - multi-line placeholder substitution value. - The 1st line or a single line value is always - placed at the placeholder. - paramindents are performed after the main - template has been indented/undented. - (indenting by position does not calculate - unicode double-wide or grapheme cluster widths) - " - #choicelabels indented by 1 char is clearer for -return string - and reasonable in table - -return -default string -choices {dict list string args}\ - -choicelabels { - dict\ - " Return a dict with keys - 'template', 'params' and - 'errors'" - string\ - " Return a single result - being the string with - placeholders substituted." - list\ - " Return a 2 element list. - The first is itself a list - of plaintext portions of the - template, split at each point - at which placeholders were - present. The second element - of the outer list is a list - of placeholder values if -eval - is 1, or a list of the raw - placeholder strings if -eval - is 0." - args\ - " Return a list where the first - element is a list of template - plaintext sections as per the - 'list' return mechanism, but the - placeholder items are individual - items in the returned list. - This can be useful when passing - the expanded result of a tstr - command to another function - which expects the placeholders - as individual arguments" - } - -eval -default 1 -type boolean -help\ - "Whether to evaluate the \$\{\} placeholders. - When -return is string, -eval should generally be set to 1. - For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. - contained variables in that case should be braced or whitespace separated, or the variable - name is likely to collide with surrounding text. - e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" - @values -min 0 -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 - e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} - - Escape sequences such as \\n and unicode escapes are processed within placeholders. - " - }] - - proc tstr {args} { - #Too hard to fully eat-our-own-dogfood from within punk::args package - # - we use punk::args within the unhappy path only - #set argd [punk::args::get_by_id ::punk::lib::tstr $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 opt_eval [dict get $argd opts -eval] - - set templatestring [lindex $args end] - set arglist [lrange $args 0 end-1] - set opts [dict create\ - -allowcommands 0\ - -undent 1\ - -indent ""\ - -paramindents line\ - -eval 1\ - -return string\ - ] - if {"-allowcommands" in $arglist} { - set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] - dict set opts -allowcommands 1 - } - if {[llength $arglist] % 2 != 0} { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr expected option/value pairs prior to last argument" - } - } - dict for {k v} $arglist { - set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] - switch -- $fullk { - -indent - -undent - -paramindents - -return - -eval { - dict set opts $fullk $v - } - default { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" - } - } - } - } - set opt_allowcommands [dict get $opts -allowcommands] - set opt_paramindents [dict get $opts -paramindents] - set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] - if {$test_paramindents ni {none line position}} { - error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." - } - set opt_paramindents $test_paramindents - set opt_return [dict get $opts -return] - set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] - if {$opt_return eq ""} { - } - set opt_eval [dict get $opts -eval] - - - set nocommands "-nocommands" - if {$opt_allowcommands == 1} { - set nocommands "" - } - - set opt_undent [dict get $opts -undent] - if {$opt_undent} { - set templatestring [punk::args::lib::undent $templatestring] - } - set opt_indent [dict get $opts -indent] - if {$opt_indent ne ""} { - set templatestring [punk::args::lib::indent $templatestring $opt_indent] - } - - #set parts [_tstr_split $templatestring] - if {[string first \$\{ $templatestring] < 0} { - set parts [list $templatestring] - } else { - set parts [_parse_tstr_parts $templatestring] - } - set textchunks [list] - #set expressions [list] - set params [list] - set idx 0 - set errors [dict create] - set lastline "" ;#todo - first line has placeholder? - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach {pt expression} $parts { - lappend textchunks $pt - incr idx ;#pt incr - - #ignore last expression - if {$idx == [llength $parts]} { - break - } - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - #lappend expressions $expression - #---------------------- - #REVIEW - JMN - #TODO - debug punk::args loading of @dynamic defs - #puts "-- $expression" - #---------------------- - #brk1 - literal newline not {\n} - set leader "" - if {[set brk1 [string first \n $expression]] >= 0} { - #undent left of paramstart only for lines of expression that arent on opening ${..} line - set tail [string range $expression $brk1+1 end] - set leader [string repeat " " [string length $lastline]] - set undentedtail [punk::args::lib::undentleader $tail $leader] - #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] - set expression "[string range $expression 0 $brk1]$undentedtail" - } - if {$opt_eval} { - if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { - lappend params [string cat \$\{ $expression \}] - dict set errors [expr {[llength $params]-1}] $result - } else { - set result [string map [list \n "\n$leader"] $result] - lappend params $result - } - #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] - } else { - #JJJ - #REVIEW - #lappend params [subst -nocommands -novariables $expression] - lappend params $expression - } - append lastline [lindex $params end] ;#for current expression's position calc - - incr idx ;#expression incr - } - - if {$opt_return eq "dict"} { - return [dict create template $textchunks params $params errors $errors] - } - if {[dict size $errors]} { - set einfo "" - dict for {i e} $errors { - append einfo "parameter $i error: $e" \n - } - #REVIEW!!! - #TODO - fix - #puts stderr "tstr errors:\n$einfo\n" - } - - switch -- $opt_return { - list { - return [list $textchunks $params] - } - args { - #see example in tstr_test_one - return [list $textchunks {*}$params] - } - string { - #todo - flag to disable indent-matching behaviour for multiline param? - set out "" - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach pt $textchunks param $params { - if {$opt_paramindents eq "none"} { - append out $pt $param - } else { - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - if {$opt_paramindents eq "line"} { - regexp {(\s*).*} $lastline _all lastindent - } else { - #position - #TODO - detect if there are grapheme clusters - #This regsub doesn't properly space unicode double-wide chars or clusters - set lastindent "[regsub -all {\S} $lastline " "] " - } - if {$lastindent ne ""} { - set paramlines [split $param \n] - if {[llength $paramlines] == 1} { - append out $pt $param - } else { - append out $pt [lindex $paramlines 0] - foreach nextline [lrange $paramlines 1 end] { - append out \n $lastindent $nextline - } - } - } else { - append out $pt $param - } - append lastline $param - } - } - return $out - } - } - } - #test single placeholder tstr args where single placeholder must be an int - proc tstr_test_one {args} { - set argd [punk::args::parse $args withdef { - @cmd -name ::punk::args::lib::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 -return args {Select * from table where id = \$\{$id\} and etc... ;}] - } - - @values -min 2 -max 2 - template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - - but the tstr call in the example 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} - }] - 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]] ""] - set result [string cat [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 dollar sign - 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]] - } - - #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. - proc indent {text {prefix " "}} { - set result [list] - foreach line [split $text \n] { - if {[string trim $line] eq ""} { - lappend result "" - } else { - lappend result $prefix[string trimright $line] - } - } - return [join $result \n] - } - #dedent? - proc undent {text} { - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - regexp {^([\t ]*)} $lcp _m lcp - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - - #hacky - proc undentleader {text leader} { - #leader usually whitespace - but doesn't have to be - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - lappend nonblank "${leader}!!" - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - #regexp {^([\t ]*)} $lcp _m lcp - #lcp can be shorter than leader - set lcp [string range $lcp 0 [string length $leader]-1] - - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - #A version of textutil::string::longestCommonPrefixList - proc longestCommonPrefix {items} { - if {[llength $items] <= 1} { - return [lindex $items 0] - } - set items [lsort $items[unset items]] - set min [lindex $items 0] - set max [lindex $items end] - #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) - #(sort order nothing to do with length - e.g min may be longer than max) - if {[string length $min] > [string length $max]} { - set temp $min - set min $max - set max $temp - } - set n [string length $min] - set prefix "" - set i -1 - while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { - append prefix $c - } - return $prefix - } - - #order-preserving - #(same as punk::lib) - proc lunique {list} { - set new {} - foreach item $list { - if {$item ni $new} { - lappend new $item - } - } - return $new - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] -} - -tcl::namespace::eval punk::args::argdocbase { - namespace export * - #use a? to test and create literal ansi here rather than relying on punk::ansi package presence - #e.g - #% a? bold - #- bold │SGR 1│sample│␛[1msample - #- ──────┼─────┼──────┼────────── - #- RESULT│ │sample│␛[1msample - proc B {} {return \x1b\[1m} ;#a+ bold - proc N {} {return \x1b\[22m} ;#a+ normal - proc I {} {return \x1b\[3m} ;#a+ italic - proc NI {} {return \x1b\[23m} ;#a+ noitalic - -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::package { - variable PUNKARGS - lappend PUNKARGS [list { - @dynamic - @id -id "::punk::args::package::standard_about" - @cmd -name "%pkg%::about" -help\ - "About %pkg% - ... - " - -package_about_namespace -type string -optional 0 -help\ - "Namespace containing the package about procedures - Must contain " - -return\ - -type string\ - -default table\ - -choices {string table tableobject}\ - -choicelabels { - string\ - "A basic text layout" - table\ - "layout in table borders - (requires package: textblock)" - tableobject\ - "textblock::class::table object instance" - }\ - -help\ - "Choose the return type of the 'about' information" - topic -optional 1\ - -nocase 1\ - -default {*}\ - -choices {Description License Version Contact *}\ - -choicerestricted 0\ - -choicelabels { - - }\ - -multiple 1\ - -help\ - "Topic to display. Omit or specify as * to see all. - If * is included with explicit topics, * represents - the remaining unmentioned topics." - }] - proc standard_about {args} { - set argd [punk::args::parse $args withid ::punk::args::package::standard_about] - lassign [dict values $argd] leaders OPTS values received - - set pkgns [dict get $OPTS -package_about_namespace] - if {[info commands ${pkgns}::package_name] eq ""} { - error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" - } - set pkgname [${pkgns}::package_name] - - set opt_return [dict get $OPTS -return] - set all_topics [${pkgns}::about_topics] - if {![dict exists $received topic]} { - set topics $all_topics - } else { - # * represents all remaining topics not explicitly mentioned. - set val_topics [dict get $values topic] ;#if -multiple is true, this is a list - set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] - set topics [list] - foreach t $val_topics { - if {$t eq "*"} { - foreach a $all_topics { - if {$a ni $explicit_topics} { - lappend topics $a - } - } - } else { - lappend topics $t - } - } - } - if {$opt_return ne "string"} { - package require textblock ;#table support - set is_table 1 - set title [string cat {[} $pkgname {]} ] - set t [textblock::class::table new -title $title] - $t configure -frametype double -minwidth [expr {[string length $title]+2}] - - } else { - set topiclens [lmap t $topics {string length $t}] - set widest_topic [tcl::mathfunc::max {*}$topiclens] - set is_table 0 - set about "$pkgname\n" - append about [string repeat - $widest_topic] \n - } - foreach topic $topics { - if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { - set topic_contents [::${pkgns}::get_topic_$topic] - } else { - set topic_contents "" - } - if {!$is_table} { - set content_lines [split $topic_contents \n] - append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n - foreach ln [lrange $content_lines 1 end] { - append about [format %-${widest_topic}s ""] " " $ln \n - } - } else { - $t add_row [list $topic $topic_contents] - } - } - - if {!$is_table} { - return $about - } else { - if {$opt_return eq "tableobject"} { - return $t - } - set result [$t print] - $t destroy - return $result - } - } - -} - -#usually we would directly call arg definitions near the defining proc, -# so that the proc could directly use the definition in its parsing. -# -#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. -#arguably it may be more processor-cache-efficient to do together like this anyway. - -#can't do this here? - as there is circular dependency with punk::lib -#tcl::namespace::eval punk::args { -# foreach deflist $PUNKARGS { -# punk::args::define {*}$deflist -# } -# set PUNKARGS "" -#} - -lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -tcl::namespace::eval punk::args::system { - #*** !doctools - #[subsection {Namespace punk::args::system}] - #[para] Internal functions that are not part of the API - - #dict get value with default wrapper for tcl 8.6 - if {[info commands ::tcl::dict::getdef] eq ""} { - proc Dict_getdef {dictValue args} { - set keys [lrange $args 0 end-1] - if {[tcl::dict::exists $dictValue {*}$keys]} { - return [tcl::dict::get $dictValue {*}$keys] - } else { - return [lindex $args end] - } - } - } else { - #we pay a minor perf penalty for the wrap - interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef - } - - #name to reflect maintenance - home is punk::lib::ldiff - proc punklib_ldiff {fromlist removeitems} { - if {[llength $removeitems] == 0} {return $fromlist} - set result {} - foreach item $fromlist { - if {$item ni $removeitems} { - lappend result $item - } - } - return $result - } - -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::args [tcl::namespace::eval punk::args { - tcl::namespace::path {::punk::args::lib ::punk::args::system} - variable pkg punk::args - variable version - set version 0.1.9 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.tm index 7b6ee228..d8c43c45 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.tm @@ -3608,7 +3608,12 @@ tcl::namespace::eval punk::args { #A_PREFIX can resolve to empty string if colour off #we then want to display underline instead set A_PREFIX [a+ underline] - set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + #set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space (zwsp) + set A_PREFIXEND [a+ nounderline] + #review - zwsp problematic on older terminals that print it visibly + #- especially if they also lie about cursor position after it's emitted. + #so although the zwsp fixes the issue where the underline extends to rhs padding if all text was underlined, + #It's probably best fixed in the padding functionality. } else { set A_PREFIXEND $RST } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm index 4d4518d3..b8b56d23 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm @@ -211,9 +211,9 @@ namespace eval punk::console { set result [dict create] if {"output" in $channels} { #note setting stdout makes stderr have the same settings - ie there is really only one output to configure - set h_out [twapi::get_console_handle stdout] + set h_out [twapi::get_console_handle stdout] set oldmode [twapi::GetConsoleMode $h_out] - set newmode [expr {$oldmode | 4}] + set newmode [expr {$oldmode | 4}] twapi::SetConsoleMode $h_out $newmode dict set result output [list from $oldmode to $newmode] } @@ -255,7 +255,7 @@ namespace eval punk::console { #as above - configuring stdout does stderr too set h_out [twapi::get_console_handle stdout] set oldmode [twapi::GetConsoleMode $h_out] - set newmode [expr {$oldmode & ~4}] + set newmode [expr {$oldmode & ~4}] twapi::SetConsoleMode $h_out $newmode dict set result output [list from $oldmode to $newmode] } @@ -412,7 +412,7 @@ namespace eval punk::console { } if {$wrote} { tsv::set console is_raw 1 - after 100 + #after 100 close $pipe } else { puts stderr "write to $ps_pipename failed trynum: $trynum\n$errMsg" diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.0.tm deleted file mode 100644 index fea9534f..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.0.tm +++ /dev/null @@ -1,1472 +0,0 @@ -# -*- 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: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.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 punk::lib 0.1.0 -# Meta platform tcl -# Meta license BSD -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::lib 0 0.1.0] -#[copyright "2024"] -#[titledesc {punk general utility functions}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk library}] [comment {-- Description at end of page heading --}] -#[require punk::lib] -#[keywords module utility lib] -#[description] -#[para]This is a set of utility functions that are commonly used across punk modules or are just considered to be general-purpose functions. -#[para]The base set includes string and math functions but has no specific theme - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of punk::lib -#[subsection Concepts] -#[para]The punk::lib modules should have no strong dependencies other than Tcl -#[para]Dependendencies that only affect display or additional functionality may be included - but should fail gracefully if not present, and only when a function is called that uses one of these soft dependencies. -#[para]This requirement for no strong dependencies, means that many utility functions that might otherwise seem worthy of inclusion here are not present. - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::lib -#[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 -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval punk::lib::class { - #*** !doctools - #[subsection {Namespace punk::lib::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 punk::lib { - namespace export * - #variable xyz - - #*** !doctools - #[subsection {Namespace punk::lib}] - #[para] Core API functions for punk::lib - #[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" - #} - - proc K {x y} {return $x} - #*** !doctools - #[call [fun K] [arg x] [arg y]] - #[para]The K-combinator function - returns the first argument, x and discards y - #[para]see [uri https://wiki.tcl-lang.org/page/K] - #[para]It is used in cases where command-substitution at the calling-point performs some desired effect. - - proc hex2dec {args} { - #*** !doctools - #[call [fun hex2dec] [opt {option value...}] [arg list_largeHex]] - #[para]Convert a list of (possibly large) unprefixed hex strings to their decimal values - #[para]hex2dec accepts and ignores internal underscores in the same manner as Tcl 8.7+ numbers e.g hex2dec FF_FF returns 65535 - #[para]Leading and trailing underscores are ignored as a matter of implementation convenience - but this shouldn't be relied upon. - #[para]Leading or trailing whitespace in each list member is allowed e.g hex2dec " F" returns 15 - #[para]Internal whitespace e.g "F F" is not permitted - but a completely empty element "" is allowed and will return 0 - - set list_largeHex [lindex $args end] - set argopts [lrange $args 0 end-1] - if {[llength $argopts]%2 !=0} { - error "[namespace current]::hex2dec arguments prior to list_largeHex must be option/value pairs - received '$argopts'" - } - set defaults [dict create\ - -validate 1\ - -empty_as_hex "INVALID set -empty_as_hex to a hex string e.g FF if empty values should be replaced"\ - ] - set known_opts [dict keys $defaults] - set fullopts [dict create] - dict for {k v} $argopts { - dict set fullopts [tcl::prefix match -message "options for hex2dec. Unexpected option" $known_opts $k] $v - } - set opts [dict merge $defaults $fullopts] - # -- --- --- --- - set opt_validate [dict get $opts -validate] - set opt_empty [dict get $opts -empty_as_hex] - # -- --- --- --- - - set list_largeHex [lmap h $list_largeHex[unset list_largeHex] {string map [list _ ""] [string trim $h]}] - if {$opt_validate} { - #Note appended F so that we accept list of empty strings as per the documentation - if {![string is xdigit -strict [join $list_largeHex ""]F ]} { - error "[namespace current]::hex2dec error: non-hex digits encountered after stripping underscores and leading/trailing whitespace for each element\n $list_largeHex" - } - } - if {![string is xdigit -strict [string map [list _ ""] $opt_empty]]} { - #mapping empty string to a value destroys any advantage of -scanonly - #todo - document that -scanonly has 2 restrictions - each element must be valid hex and less than 7 chars long - #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {0} : {[set v]}}] - if {[lsearch $list_largeHex ""] >=0} { - error "[namespace current]::hex2dec error: empty values in list cannot be mapped to non-hex $opt_empty" - } - } else { - set opt_empty [string trim [string map [list _ ""] $opt_empty]] - if {[set first_empty [lsearch $list_largeHex ""]] >= 0} { - #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {$opt_empty} : {$v}}] - set nonempty_head [lrange $list_largeHex 0 $first_empty-1] - set list_largeHex [concat $nonempty_head [lmap v [lrange $list_largeHex $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] - } - } - return [scan $list_largeHex [string repeat %llx [llength $list_largeHex]]] - } - - proc dec2hex {args} { - #*** !doctools - #[call [fun dex2hex] [opt {option value...}] [arg list_decimals]] - #[para]Convert a list of decimal integers to a list of hex values - #[para] -width can be used to make each hex value at least int characters wide, with leading zeroes. - #[para] -case upper|lower determines the case of the hex letters in the output - set list_decimals [lindex $args end] - set argopts [lrange $args 0 end-1] - if {[llength $argopts]%2 !=0} { - error "[namespace current]::dec2hex arguments prior to list_decimals must be option/value pairs - received '$argopts'" - } - set defaults [dict create\ - -width 1\ - -case upper\ - -empty_as_decimal "INVALID set -empty_as_decimal to a number if empty values should be replaced"\ - ] - set known_opts [dict keys $defaults] - set fullopts [dict create] - dict for {k v} $argopts { - dict set fullopts [tcl::prefix match -message "options for [namespace current]::dec2hex. Unexpected option" $known_opts $k] $v - } - set opts [dict merge $defaults $fullopts] - # -- --- --- --- - set opt_width [dict get $opts -width] - set opt_case [dict get $opts -case] - set opt_empty [dict get $opts -empty_as_decimal] - # -- --- --- --- - - - set resultlist [list] - if {[string tolower $opt_case] eq "upper"} { - set spec X - } elseif {[string tolower $opt_case] eq "lower"} { - set spec x - } else { - error "[namespace current]::dec2hex unknown value '$opt_case' for -case expected upper|lower" - } - set fmt "%${opt_width}.${opt_width}ll${spec}" - - set list_decimals [lmap d $list_decimals[unset list_decimals] {string map [list _ ""] [string trim $d]}] - if {![string is digit -strict [string map [list _ ""] $opt_empty]]} { - if {[lsearch $list_decimals ""] >=0} { - error "[namespace current]::dec2hex error: empty values in list cannot be mapped to non-decimal $opt_empty" - } - } else { - set opt_empty [string map [list _ ""] $opt_empty] - if {[set first_empty [lsearch $list_decimals ""]] >= 0} { - set nonempty_head [lrange $list_decimals 0 $first_empty-1] - set list_decimals [concat $nonempty_head [lmap v [lrange $list_decimals $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] - } - } - return [format [lrepeat [llength $list_decimals] $fmt] {*}$list_decimals] - } - - proc log2 x "expr {log(\$x)/[expr log(2)]}" - #*** !doctools - #[call [fun log2] [arg x]] - #[para]log base2 of x - #[para]This uses a 'live' proc body - the divisor for the change of base is computed once at definition time - #[para](courtesy of RS [uri https://wiki.tcl-lang.org/page/Additional+math+functions]) - - proc logbase {b x} { - #*** !doctools - #[call [fun logbase] [arg b] [arg x]] - #[para]log base b of x - #[para]This function uses expr's natural log and the change of base division. - #[para]This means for example that we can get results like: logbase 10 1000 = 2.9999999999999996 - #[para]Use expr's log10() function or tcl::mathfunc::log10 for base 10 - expr {log($x)/log($b)} - } - proc factors {x} { - #*** !doctools - #[call [fun factors] [arg x]] - #[para]Return a sorted list of the positive factors of x where x > 0 - #[para]For x = 0 we return only 0 and 1 as technically any number divides zero and there are an infinite number of factors. (including zero itself in this context)* - #[para]This is a simple brute-force implementation that iterates all numbers below the square root of x to check the factors - #[para]Because the implementation is so simple - the performance is very reasonable for numbers below at least a few 10's of millions - #[para]See tcllib math::numtheory::factors for a more complex implementation - which seems to be slower for 'small' numbers - #[para]Comparisons were done with some numbers below 17 digits long - #[para]For seriously big numbers - this simple algorithm would no doubt be outperformed by more complex algorithms. - #[para]The numtheory library stores some data about primes etc with each call - so may become faster when being used on more numbers - #but has the disadvantage of being slower for 'small' numbers and using more memory. - #[para]If the largest factor below x is needed - the greatestOddFactorBelow and GreatestFactorBelow functions are a faster way to get there than computing the whole list, even for small values of x - #[para]* Taking x=0; Notion of x being divisible by integer y being: There exists an integer p such that x = py - #[para] In other mathematical contexts zero may be considered not to divide anything. - set factors [list 1] - set j 2 - set max [expr {sqrt($x)}] - while {$j <= $max} { - if {($x % $j) == 0} { - lappend factors $j [expr {$x / $j}] - } - incr j - } - lappend factors $x - return [lsort -unique -integer $factors] - } - proc oddFactors {x} { - #*** !doctools - #[call [fun oddFactors] [arg x]] - #[para]Return a list of odd integer factors of x, sorted in ascending order - set j 2 - set max [expr {sqrt($x)}] - set factors [list 1] - while {$j <= $max} { - if {$x % $j == 0} { - set other [expr {$x / $j}] - if {$other % 2 != 0} { - if {$other ni $factors} { - lappend factors $other - } - } - if {$j % 2 != 0} { - if {$j ni $factors} { - lappend factors $j - } - } - } - incr j - } - return [lsort -integer -increasing $factors] - } - proc greatestFactorBelow {x} { - #*** !doctools - #[call [fun greatestFactorBelow] [arg x]] - #[para]Return the largest factor of x excluding itself - #[para]factor functions can be useful for console layout calculations - #[para]See Tcllib math::numtheory for more extensive implementations - if {$x % 2 == 0 || $x == 0} { - return [expr {$x / 2}] - } - set j 3 - set max [expr {sqrt($x)}] - while {$j <= $max} { - if {$x % $j == 0} { - return [expr {$x / $j}] - } - incr j 2 - } - return 1 - } - proc greatestOddFactorBelow {x} { - #*** !doctools - #[call [fun greatestOddFactorBelow] [arg x]] - #[para]Return the largest odd integer factor of x excluding x itself - if {$x %2 == 0} { - return [greatestOddFactor $x] - } - set j 3 - #dumb brute force - time taken to compute is wildly variable on big numbers - #todo - use a (memoized?) generator of primes to reduce the search space - #tcllib math::numtheory has suitable functions - but do we want that dependency here? Testing shows brute-force often faster for small numbers. - set god 1 - set max [expr {sqrt($x)}] - while { $j <= $max} { - if {$x % $j == 0} { - set other [expr {$x / $j}] - if {$other % 2 == 0} { - set god $j - } else { - set god [expr {$x / $j}] - #lowest j - so other side must be highest - break - } - } - incr j 2 - } - return $god - } - proc greatestOddFactor {x} { - #*** !doctools - #[call [fun greatestOddFactor] [arg x]] - #[para]Return the largest odd integer factor of x - #[para]For an odd value of x - this will always return x - if {$x % 2 != 0 || $x == 0} { - return $x - } - set r [expr {$x / 2}] - while {$r % 2 == 0} { - set r [expr {$r / 2}] - } - return $r - } - proc gcd {n m} { - #*** !doctools - #[call [fun gcd] [arg n] [arg m]] - #[para]Return the greatest common divisor of m and n - #[para]Straight from Lars Hellström's math::numtheory library in Tcllib - #[para]Graphical use: - #[para]An a by b rectangle can be covered with square tiles of side-length c, - #[para]only if c is a common divisor of a and b - - # - # Apply Euclid's good old algorithm - # - if { $n > $m } { - set t $n - set n $m - set m $t - } - - while { $n > 0 } { - set r [expr {$m % $n}] - set m $n - set n $r - } - - return $m - } - proc lcm {n m} { - #*** !doctools - #[call [fun gcd] [arg n] [arg m]] - #[para]Return the lowest common multiple of m and n - #[para]Straight from Lars Hellström's math::numtheory library in Tcllib - #[para] - set gcd [gcd $n $m] - return [expr {$n*$m/$gcd}] - } - proc commonDivisors {x y} { - #*** !doctools - #[call [fun commonDivisors] [arg x] [arg y]] - #[para]Return a list of all the common factors of x and y - #[para](equivalent to factors of their gcd) - return [factors [gcd $x $y]] - } - - #experimental only - there are better/faster ways - proc sieve n { - set primes [list] - if {$n < 2} {return $primes} - set nums [dict create] - for {set i 2} {$i <= $n} {incr i} { - dict set nums $i "" - } - set next 2 - set limit [expr {sqrt($n)}] - while {$next <= $limit} { - for {set i $next} {$i <= $n} {incr i $next} {dict unset nums $i} - lappend primes $next - dict for {next -} $nums break - } - return [concat $primes [dict keys $nums]] - } - proc sieve2 n { - set primes [list] - if {$n < 2} {return $primes} - set nums [dict create] - for {set i 2} {$i <= $n} {incr i} { - dict set nums $i "" - } - set next 2 - set limit [expr {sqrt($n)}] - while {$next <= $limit} { - for {set i $next} {$i <= $n} {incr i $next} {dict unset nums $i} - lappend primes $next - #dict for {next -} $nums break - set next [lindex $nums 0] - } - return [concat $primes [dict keys $nums]] - } - - proc hasglobs {str} { - #*** !doctools - #[call [fun hasglobs] [arg str]] - #[para]Return a boolean indicating whether str contains any of the glob characters: * ? [lb] [rb] - #[para]hasglobs uses append to preserve Tcls internal representation for str - so it should help avoid shimmering in the few cases where this may matter. - regexp {[*?\[\]]} [append obj2 $str {}] ;# int-rep preserving - } - - proc trimzero {number} { - #*** !doctools - #[call [fun trimzero] [arg number]] - #[para]Return number with left-hand-side zeros trimmed off - unless all zero - #[para]If number is all zero - a single 0 is returned - set trimmed [string trimleft $number 0] - if {[string length $trimmed] == 0} { - set trimmed 0 - } - return $trimmed - } - proc substring_count {str substring} { - #*** !doctools - #[call [fun substring_count] [arg str] [arg substring]] - #[para]Search str and return number of occurrences of substring - - #faster than lsearch on split for str of a few K - if {$substring eq ""} {return 0} - set occurrences [expr {[string length $str]-[string length [string map [list $substring {}] $str]]}] - return [expr {$occurrences / [string length $substring]}] - } - - proc dict_merge_ordered {defaults main} { - #*** !doctools - #[call [fun dict_merge_ordered] [arg defaults] [arg main]] - #[para]The standard dict merge accepts multiple dicts with values from dicts to the right (2nd argument) taking precedence. - #[para]When merging with a dict of default values - this means that any default key/vals that weren't in the main dict appear in the output before the main data. - #[para]This function merges the two dicts whilst maintaining the key order of main followed by defaults. - - #1st merge (inner merge) with wrong values taking precedence - but right key-order - then (outer merge) restore values - return [dict merge [dict merge $main $defaults] $main] - } - - proc askuser {question} { - #*** !doctools - #[call [fun askuser] [arg question]] - #[para]A basic utility to read an answer from stdin - #[para]The prompt is written to the terminal and then it waits for a user to type something - #[para]stdin is temporarily configured to blocking and then put back in its original state in case it wasn't already so. - #[para]If the terminal is using punk::console and is in raw mode - the terminal will temporarily be put in line mode. - #[para](Generic terminal raw vs linemode detection not yet present) - #[para]The user must hit enter to submit the response - #[para]The return value is the string if any that was typed prior to hitting enter. - #[para]The question argument can be manually colourised using the various punk::ansi funcitons - #[example_begin] - # set answer [lb]punk::lib::askuser "[lb]a+ green bold[rb]Do you want to proceed? (Y|N)[lb]a[rb]"[rb] - # if {[lb]string match y* [lb]string tolower $answer[rb][rb]} { - # puts "Proceeding" - # } else { - # puts "Cancelled by user" - # } - #[example_end] - puts stdout $question - flush stdout - set stdin_state [fconfigure stdin] - if {[catch { - package require punk::console - set console_raw [set ::punk::console::is_raw] - } err_console]} { - #assume normal line mode - set console_raw 0 - } - try { - fconfigure stdin -blocking 1 - if {$console_raw} { - punk::console::disableRaw - set answer [gets stdin] - punk::console::enableRaw - } else { - set answer [gets stdin] - } - } finally { - fconfigure stdin -blocking [dict get $stdin_state -blocking] - } - 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 - #[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 ? " - } - 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} { - #*** !doctools - #[call [fun lines_as_list] [opt {option value ...}] [arg text]] - #[para]Returns a list of possibly trimmed lines depeding on options - #[para]The concept of lines is raw lines from splitting on newline after crlf is mapped to lf - #[para]- not console lines which may be entirely different due to control characters such as vertical tabs or ANSI movements - - #The underlying function linelist has the validation code which gives nicer 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 text" - if {[llength $args] == 0} { - error "linelist missing textchunk argument usage:$usage" - } - set text [lindex $args end] - set text [string map [list \r\n \n] $text] ;#review - option? - - 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 values - #[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 , -maxvalues , -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 - #[list_end] [comment {--- end definitions namespace punk::lib ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#todo - way to generate 'internal' docs separately? -#*** !doctools -#[section Internal] -namespace eval punk::lib::system { - #*** !doctools - #[subsection {Namespace punk::lib::system}] - #[para] Internal functions that are not part of the API - #[list_begin definitions] - - proc mostFactorsBelow {n} { - ##*** !doctools - #[call [fun mostFactorsBelow] [arg n]] - #[para]Find the number below $n which has the greatest number of factors - #[para]This will get slow quickly as n increases (100K = 1s+ 2024) - set most 0 - set mostcount 0 - for {set i 1} {$i < $n} {incr i} { - set fc [llength [punk::lib::factors $i]] - if {$fc > $mostcount} { - set most $i - set mostcount $fc - } - } - return [list number $most numfactors $mostcount] - } - proc factorCountBelow_punk {n} { - ##*** !doctools - #[call [fun factorCountBelow] [arg n]] - #[para]For numbers 1 to n - keep a tally of the total count of factors - #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result - #[para]and as a rudimentary performance comparison - #[para]gets slow quickly! - set tally 0 - for {set i 1} {$i <= $n} {incr i} { - incr tally [llength [punk::lib::factors $i]] - } - return $tally - } - proc factorCountBelow_numtheory {n} { - ##*** !doctools - #[call [fun factorCountBelow] [arg n]] - #[para]For numbers 1 to n - keep a tally of the total count of factors - #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result - #[para]and as a rudimentary performance comparison - #[para]gets slow quickly! (significantly slower than factorCountBelow_punk) - package require math::numtheory - set tally 0 - for {set i 1} {$i <= $n} {incr i} { - incr tally [llength [math::numtheory::factors $i]] - } - return $tally - } - - proc factors2 {x} { - ##*** !doctools - #[call [fun factors2] [arg x]] - #[para]Return a sorted list of factors of x - #[para]A similar brute-force mechanism to factors - but keeps result ordering as we go. - set smallfactors [list 1] - set j 2 - set max [expr {sqrt($x)}] - while {$j < $max} { - if {($x % $j) == 0} { - lappend smallfactors $j - lappend largefactors [expr {$x / $j}] - } - incr j - } - #handle sqrt outside loop so we don't have to sort/dedup or check list membership in main loop - if {($x % $j) == 0} { - if {$j == ($x / $j)} { - lappend smallfactors $j - } - } - return [concat $smallfactors [lreverse $largefactors] $x] - } - - #important - used by punk::repl - proc incomplete {partial} { - #we can apparently get away without concatenating current innerpartial to previous in list - REVIEW. - if {[info complete $partial]} { - return [list] - } - set clist [split $partial ""] - #puts stderr "-->$clist<--" - set waiting [list ""] - set innerpartials [list ""] - set escaped 0 - foreach c $clist { - if {$c eq "\\"} { - set escaped [expr {!$escaped}] - continue - } ;# set escaped 0 at end - set p [lindex $innerpartials end] - if {$escaped == 0} { - if {$c eq {"}} { - if {![info complete ${p}]} { - lappend waiting {"} - lappend innerpartials "" - } else { - if {[lindex $waiting end] eq {"}} { - #this quote is endquote - set waiting [lrange $waiting 0 end-1] - set innerpartials [lrange $innerpartials 0 end-1] - } else { - if {![info complete ${p}$c]} { - lappend waiting {"} - lappend innerpartials "" - } else { - set p ${p}${c} - lset innerpartials end $p - } - } - } - } elseif {$c eq "\["} { - if {![info complete ${p}$c]} { - lappend waiting "\]" - lappend innerpartials "" - } else { - set p ${p}${c} - lset innerpartials end $p - } - } elseif {$c eq "\{"} { - if {![info complete ${p}$c]} { - lappend waiting "\}" - lappend innerpartials "" - } else { - set p ${p}${c} - lset innerpartials end $p - } - } else { - set waitingfor [lindex $waiting end] - if {$c eq "$waitingfor"} { - set waiting [lrange $waiting 0 end-1] - set innerpartials [lrange $innerpartials 0 end-1] - } else { - set p ${p}${c} - lset innerpartials end $p - } - } - } else { - set p ${p}${c} - lset innerpartials end $p - } - set escaped 0 - } - set incomplete [list] - foreach w $waiting { - if {$w eq {"}} { - lappend incomplete $w - } elseif {$w eq "\]"} { - lappend incomplete "\[" - } elseif {$w eq "\}"} { - lappend incomplete "\{" - } - } - set debug 0 - if {$debug} { - foreach w $waiting p $innerpartials { - puts stderr "->'$w' partial: $p" - } - } - return $incomplete - } - #This only works for very simple cases will get confused with for example: - # {set x "a["""} - proc incomplete_naive {partial} { - if {[info complete $partial]} { - return [list] - } - set clist [split $partial ""] - set waiting [list] - set escaped 0 - foreach c $clist { - if {$c eq "\\"} { - set escaped [expr {!$escaped}] - continue - } - if {!$escaped} { - if {$c eq {"}} { - if {[lindex $waiting end] eq {"}} { - set waiting [lrange $waiting 0 end-1] - } else { - lappend waiting {"} - } - } elseif {$c eq "\["} { - lappend waiting "\]" - } elseif {$c eq "\{"} { - lappend waiting "\}" - } else { - set waitingfor [lindex $waiting end] - if {$c eq "$waitingfor"} { - set waiting [lrange $waiting 0 end-1] - } - } - } - } - set incomplete [list] - foreach w $waiting { - if {$w eq {"}} { - lappend incomplete $w - } elseif {$w eq "\]"} { - lappend incomplete "\[" - } elseif {$w eq "\}"} { - lappend incomplete "\{" - } - } - return $incomplete - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::lib::system ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::lib [namespace eval punk::lib { - variable pkg punk::lib - variable version - set version 0.1.0 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm deleted file mode 100644 index b6c6dd4a..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm +++ /dev/null @@ -1,4238 +0,0 @@ -# -*- 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: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.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 punk::lib 0.1.1 -# Meta platform tcl -# Meta license BSD -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::lib 0 0.1.1] -#[copyright "2024"] -#[titledesc {punk general utility functions}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk library}] [comment {-- Description at end of page heading --}] -#[require punk::lib] -#[keywords module utility lib] -#[description] -#[para]This is a set of utility functions that are commonly used across punk modules or are just considered to be general-purpose functions. -#[para]The base set includes string and math functions but has no specific theme - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of punk::lib -#[subsection Concepts] -#[para]The punk::lib modules should have no strong dependencies other than Tcl -#[para]Dependendencies that only affect display or additional functionality may be included - but should fail gracefully if not present, and only when a function is called that uses one of these soft dependencies. -#[para]This requirement for no strong dependencies, means that many utility functions that might otherwise seem worthy of inclusion here are not present. - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::lib -#[list_begin itemized] - -package require Tcl 8.6- -package require punk::args -#*** !doctools -#[item] [package {Tcl 8.6-}] -#[item] [package {punk::args}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - - -tcl::namespace::eval punk::lib::ensemble { - #wiki.tcl-lang.org/page/ensemble+extend - # extend an ensemble-like routine with the routines in some namespace - proc extend {routine extension} { - if {![string match ::* $routine]} { - set resolved [uplevel 1 [list ::tcl::namespace::which $routine]] - if {$resolved eq {}} { - error [list {no such routine} $routine] - } - set routine $resolved - } - set routinens [tcl::namespace::qualifiers $routine] - if {$routinens eq {::}} { - set routinens {} - } - set routinetail [tcl::namespace::tail $routine] - - if {![string match ::* $extension]} { - set extension [uplevel 1 [ - list [tcl::namespace::which namespace] current]]::$extension - } - - if {![tcl::namespace::exists $extension]} { - error [list {no such namespace} $extension] - } - - set extension [tcl::namespace::eval $extension [ - list [tcl::namespace::which namespace] current]] - - tcl::namespace::eval $extension [ - list [tcl::namespace::which namespace] export *] - - while 1 { - set renamed ${routinens}::${routinetail}_[clock clicks] ;#clock clicks unlikely to collide when not directly consecutive such as: list [clock clicks] [clock clicks] - if {[tcl::namespace::which $renamed] eq {}} break - } - - rename $routine $renamed - - tcl::namespace::eval $extension [ - list namespace ensemble create -command $routine -unknown [ - list apply {{renamed ensemble routine args} { - list $renamed $routine - }} $renamed - ] - ] - - return $routine - } -} - -# some (?) tcl bug check procs needed to exist before main punk::lib namespaces are evaluated -tcl::namespace::eval punk::lib::check { - proc has_tclbug_script_var {} { - - set script {set j [list spud] ; list} - append script \n - uplevel #0 $script - set rep1 [tcl::unsupported::representation $::j] - set script "" - set rep2 [tcl::unsupported::representation $::j] - - set nostring1 [string match "*no string" $rep1] - set nostring2 [string match "*no string" $rep2] - - #we assume it should have no string rep in either case - #Review: check Tcl versions for behaviour/consistency - if {!$nostring2} { - return true - } else { - return false - } - } - proc has_tclbug_lsearch_strideallinline {} { - #bug only occurs with single -index value combined with -stride -all -inline -subindices - #https://core.tcl-lang.org/tcl/tktview/5a1aaa201d - if {[catch {lsearch -stride 3 -all -inline -index 1 -subindices {a1 a2 a3} *} result]} { - #we aren't looking for an error result - error most likely indicates tcl too old to support -stride - return 0 - } - return [expr {$result ne "a2"}] - } - - proc has_tclbug_list_quoting_emptyjoin {} { - #https://core.tcl-lang.org/tcl/tktview/e38dce74e2 - set v1 [list {*}[lindex #foo] {*}[]] ;#can return "#foo" instead of "{#foo}" under some beta 9 releases - set v2 [list #foo] ;#normal tcl list quoting for 1st element that looks like a comment -> "{#foo}" - return [expr {![string equal $v1 $v2]}] ;#if they're not equal - we have the bug. - } - - proc has_tclbug_safeinterp_compile {{show 0}} { - #ensemble calls within safe interp not compiled - namespace eval [namespace current]::testcompile { - proc ensembletest {} {string index a 0} - } - - set has_bug 0 - - set bytecode_outer [tcl::unsupported::disassemble proc [namespace current]::testcompile::ensembletest] - if {$show} { - puts outer: - puts $bytecode_outer - } - if {![interp issafe]} { - #test of safe subinterp only needed if we aren't already in a safe interp - if {![catch { - interp create x -safe - } errMsg]} { - x eval {proc ensembletest {} {string index a 0}} - set bytecode_safe [x eval {tcl::unsupported::disassemble proc ::ensembletest}] - if {$show} { - puts safe: - puts $bytecode_safe - } - interp delete x - #mainly we expect the safe interp might contain invokeStk - indicating not byte compiled (or we would see strindex instead) - #It's possible the interp we're running in is also not compiling ensembles. - #we could then get a result of 2 - which still indicates a problem - if {[string last "invokeStk" $bytecode_safe] >= 1} { - incr has_bug - } - } else { - #our failure to create a safe interp here doesn't necessarily mean the Tcl version doesn't have the problem - but we could end up returning zero if somehow safe interp can't be created from unsafe interp? - #unlikely - but we should warn - puts stderr "Unable to create a safe sub-interp to test - result only indicates status of current interpreter" - } - } - - namespace delete [namespace current]::testcompile - - if {[string last "invokeStk" $bytecode_outer] >= 1} { - incr has_bug - } - return $has_bug - } -} - -tcl::namespace::eval punk::lib::compat { - #*** !doctools - #[subsection {Namespace punk::lib::compat}] - #[para] compatibility functions for features that may not be available in earlier Tcl versions - #[para] These are generally 'forward compatibility' functions ie allowing earlier versions to use later features/idioms by using a Tcl-only version of a missing builtin. - #[para] Such Tcl-only versions will inevitably be less performant - perhaps significantly so. - - #*** !doctools - #[list_begin definitions] - - - - - if {"::lremove" ne [info commands ::lremove]} { - #puts stderr "Warning - no built-in lremove" - interp alias {} lremove {} ::punk::lib::compat::lremove - } - proc lremove {list args} { - #*** !doctools - #[call [fun lremove] [arg list] [opt {index ...}]] - #[para] Forwards compatible lremove for versions 8.6 or less to support equivalent 8.7 lremove - - set data [lmap v $list {list data $v}] - foreach doomed_index $args { - if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"} - lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value - } - set keep [lsearch -all -inline -not -exact $data x] - return [lsearch -all -inline -index 1 -subindices $keep *] - } - #not significantly different in performance over test of 100 elements - getting somewhere near 10% for 1k integers - proc lremove2 {list args} { - set data [lmap v $list {list data $v}] - foreach doomed_index $args { - if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"} - lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value - } - set keep [lsearch -all -inline -not -exact $data x] - return [lmap v $keep {lindex $v 1}] - } - #outside of lmap - don't know of any particularly nice ways to flatten to subindex 1 of each element.. - #flattening then lsearch with -stride and * would be nice - but it's not avail in 8.6 - - if {![info exists ::auto_index(readFile)]} { - if {[info commands ::readFile] eq ""} { - proc ::readFile {filename {mode text}} { - #readFile not seen in auto_index or as command: installed by punk::lib - # Parse the arguments - set MODES {binary text} - set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]] - set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode] - - # Read the file - set f [open $filename [dict get {text r binary rb} $mode]] - try { - return [read $f] - } finally { - close $f - } - } - } - } - if {![info exists ::auto_index(writeFile)]} { - if {[info commands ::writeFile] eq ""} { - proc ::writeFile {args} { - #writeFile not seen in auto_index or as command: installed by punk::lib - # Parse the arguments - switch [llength $args] { - 2 { - lassign $args filename data - set mode text - } - 3 { - lassign $args filename mode data - set MODES {binary text} - set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]] - set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode] - } - default { - set COMMAND [lindex [info level 0] 0] - return -code error -errorcode {TCL WRONGARGS} "wrong # args: should be \"$COMMAND filename ?mode? data\"" - } - } - - # Write the File - set f [open $filename [dict get {text w binary wb} $mode]] - try { - puts -nonewline $f $data - } finally { - close $f - } - } - } - } - - if {"::lpop" ne [info commands ::lpop]} { - #puts stderr "Warning - no built-in lpop" - interp alias {} lpop {} ::punk::lib::compat::lpop - } - proc lpop {lvar args} { - #*** !doctools - #[call [fun lpop] [arg listvar] [opt {index}]] - #[para] Forwards compatible lpop for versions 8.6 or less to support equivalent 8.7 lpop - upvar $lvar l - if {![llength $args]} { - set args [list end] - } - set v [lindex $l {*}$args] - set newlist $l - - set path [list] - set subl $l - for {set i 0} {$i < [llength $args]} {incr i} { - set idx [lindex $args $i] - if {![llength [lrange $subl $idx $idx]]} { - error "tcl_lpop index \"$idx\" out of range" - } - lappend path [lindex $args $i] - set subl [lindex $l {*}$path] - } - - set sublist_path [lrange $args 0 end-1] - set tailidx [lindex $args end] - if {![llength $sublist_path]} { - #set newlist [lremove $newlist $tailidx] - set newlist [lreplace $newlist $tailidx $tailidx] - } else { - set sublist [lindex $newlist {*}$sublist_path] - #set sublist [lremove $sublist $tailidx] - set sublist [lreplace $sublist $tailidx $tailidx] - lset newlist {*}$sublist_path $sublist - } - #puts "[set l] -> $newlist" - set l $newlist - return $v - } - - - #slight isolation - varnames don't leak - but calling context vars can be affected - proc lmaptcl2 {varnames list script} { - set result [list] - set values [list] - foreach v $varnames { - lappend values "\$$v" - } - set linkvars [uplevel 1 [list info vars]] - set nscaller [uplevel 1 [list namespace current]] - - set apply_script "" - foreach vname $linkvars { - append apply_script [string map [list %vname% $vname]\ - {upvar 2 %vname% %vname%}\ - ] \n - } - append apply_script $script \n - - #puts "--> $apply_script" - foreach $varnames $list { - lappend result [apply\ - [list\ - $varnames\ - $apply_script\ - $nscaller\ - ] {*}[subst $values]\ - ] - } - return $result - } - - if {"::lmap" ne [info commands ::lmap]} { - #puts stderr "Warning - no built-in lpop" - interp alias {} lmap {} ::punk::lib::compat::lmaptcl - } - #lmap came in Tcl 8.6 - so probably not much need for a tcl forward compatibility version - but here it is anyway - proc lmaptcl {varnames list script} { - set result [list] - set varlist [list] - foreach varname $varnames { - upvar 1 $varname var_$varname ;#ensure no collisions with vars in this proc - lappend varlist var_$varname - } - foreach $varlist $list { - lappend result [uplevel 1 $script] - } - return $result - } - - #tcl8.7/9 compatibility for 8.6 - if {[info commands ::tcl::string::insert] eq ""} { - #https://wiki.tcl-lang.org/page/string+insert - # Pure Tcl implementation of [string insert] command. - proc ::tcl::string::insert {string index insertString} { - # Convert end-relative and TIP 176 indexes to simple integers. - if {[regexp -expanded { - ^(end(?![\t\n\v\f\r ]) # "end" is never followed by whitespace - |[\t\n\v\f\r ]*[+-]?\d+) # m, with optional leading whitespace - (?:([+-]) # op, omitted when index is "end" - ([+-]?\d+))? # n, omitted when index is "end" - [\t\n\v\f\r ]*$ # optional whitespace (unless "end") - } $index _ m op n]} { - # Convert first index to an integer. - switch $m { - end {set index [string length $string]} - default {scan $m %d index} - } - - # Add or subtract second index, if provided. - switch $op { - + {set index [expr {$index + $n}]} - - {set index [expr {$index - $n}]} - } - } elseif {![string is integer -strict $index]} { - # Reject invalid indexes. - return -code error "bad index \"$index\": must be\ - integer?\[+-\]integer? or end?\[+-\]integer?" - } - - # Concatenate the pre-insert, insertion, and post-insert strings. - string cat [string range $string 0 [expr {$index - 1}]] $insertString\ - [string range $string $index end] - } - - # Bind [string insert] to [::tcl::string::insert]. - tcl::namespace::ensemble configure string -map [tcl::dict::replace\ - [tcl::namespace::ensemble configure string -map]\ - insert ::tcl::string::insert] - } - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::lib::compat ---}] -} - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval punk::lib { - variable PUNKARGS - tcl::namespace::export * - variable has_struct_list - set has_struct_list [expr {![catch {package require struct::list}]}] - variable has_struct_set - set has_struct_set [expr {![catch {package require struct::set}]}] - variable has_punk_ansi - set has_punk_ansi [expr {![catch {package require punk::ansi}]}] - set has_twapi 0 - if {"windows" eq $::tcl_platform(platform)} { - set has_twapi [expr {![catch {package require twapi}]}] - } - - #NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed) - proc aliases {{glob *}} { - set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command - set ns_mapped [string map {:: \uFFFF} $ns] - #puts stderr "aliases ns: $ns_mapped" - set segments [split $ns_mapped \uFFFF] ;#include empty string before leading :: - if {![string length [lindex $segments end]]} { - #special case for :: only include leading segment rather thatn {} {} - set segments [lrange $segments 0 end-1] - } - set segcount [llength $segments] ;#only match number of segments matching current ns - - - set all_aliases [interp aliases {}] - set matched [list] - foreach a $all_aliases { - #normalize with leading :: - if {![string match ::* $a]} { - set abs ::$a - } else { - set abs $a - } - - set asegs [split [string map {:: \uFFFF} $abs] \uFFFF] - set acount [llength $asegs] - #puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments" - if {($acount - 1) == $segcount} { - if {[lrange $asegs 0 end-1] eq $segments} { - if {[string match $glob [lindex $asegs end]]} { - #report this alias in the current namespace - even though there may be no matching command - lappend matched $a ;#add raw alias token which may or may not have leading :: - } - } - } - } - #set matched_abs [lsearch -all -inline $all_aliases $glob] - - return $matched - } - - proc alias {{aliasorglob ""} args} { - set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command - if {[llength $args]} { - if {$aliasorglob in [interp aliases ""]} { - set existing [interp alias "" $aliasorglob] - puts stderr "Overwriting existing alias $aliasorglob -> $existing with $aliasorglob -> $args (in current session only)" - } - if {([llength $args] ==1) && [string trim [lindex $args 0]] eq ""} { - #use empty string/whitespace as intention to delete alias - return [interp alias "" $aliasorglob ""] - } - return [interp alias "" $aliasorglob "" {*}$args] - } else { - if {![string length $aliasorglob]} { - set aliaslist [punk::lib::aliases] - puts -nonewline stderr $aliaslist - return - } - #we need to first check for exact match of alias that happens to have glob chars i.e the supplied aliasorglob looks like a glob but is actually directly an alias - set target [interp alias "" $aliasorglob] - if {[llength $target]} { - return $target - } - - if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} { - set aliaslist [punk::lib::aliases $aliasorglob] - puts -nonewline stderr $aliaslist - return - } - return [list] - } - } - - - # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == - # Maintenance - This is the primary source for tm_version... functions - # - certain packages script require these but without package dependency - # - 1 punk boot script - # - 2 packagetrace module - # - These should be updated to sync with this - # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == - proc tm_version_isvalid {versionpart} { - #Needs to be suitable for use with Tcl's 'package vcompare' - if {![catch [list package vcompare $versionpart $versionpart]]} { - return 1 - } else { - return 0 - } - } - proc tm_version_major {version} { - if {![tm_version_isvalid $version]} { - error "Invalid version '$version' is not a proper Tcl module version number" - } - set firstpart [lindex [split $version .] 0] - #check for a/b in first segment - if {[string is integer -strict $firstpart]} { - return $firstpart - } - if {[string first a $firstpart] > 0} { - return [lindex [split $firstpart a] 0] - } - if {[string first b $firstpart] > 0} { - return [lindex [split $firstpart b] 0] - } - error "tm_version_major unable to determine major version from version number '$version'" - } - proc tm_version_canonical {ver} { - #accepts a single valid version only - not a bounded or unbounded spec - if {![tm_version_isvalid $ver]} { - error "tm_version_canonical version '$ver' is not valid for a package version" - } - set parts [split $ver .] - set newparts [list] - foreach o $parts { - set trimmed [string trimleft $o 0] - set firstnonzero [string index $trimmed 0] - switch -exact -- $firstnonzero { - "" { - lappend newparts 0 - } - a - b { - #e.g 000bnnnn -> bnnnnn - set tailtrimmed [string trimleft [string range $trimmed 1 end] 0] - if {$tailtrimmed eq ""} { - set tailtrimmed 0 - } - lappend newparts 0$firstnonzero$tailtrimmed - } - default { - #digit - if {[string is integer -strict $trimmed]} { - #e.g 0100 -> 100 - lappend newparts $trimmed - } else { - #e.g 0100b003 -> 100b003 (still need to process tail) - if {[set apos [string first a $trimmed]] > 0} { - set lhs [string range $trimmed 0 $apos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch - set rhs [string range $trimmed $apos+1 end] ;#assert rhs non-empty and only digits - set rhs [string trimleft $rhs 0] - if {$rhs eq ""} { - set rhs 0 - } - lappend newparts ${lhs}a${rhs} - } elseif {[set bpos [string first b $trimmed]] > 0} { - set lhs [string range $trimmed 0 $bpos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch - set rhs [string range $trimmed $bpos+1 end] ;#assert rhs non-empty and only digits - set rhs [string trimleft $rhs 0] - if {$rhs eq ""} { - set rhs 0 - } - lappend newparts ${lhs}b${rhs} - } else { - #assert - shouldn't get here trimmed val should have been empty, an int or contained an a or b - error "tm_version_canonical error - trimfail - unexpected" - } - } - } - } - } - return [join $newparts .] - } - proc tm_version_required_canonical {versionspec} { - #also trim leading zero from any dottedpart? - #Tcl *allows* leading zeros in any of the dotted parts - but they are not significant. - #e.g 1.01 is equivalent to 1.1 and 01.001 - #also 1b3 == 1b0003 - - if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version - set errmsg "tm_version_required_canonical - invalid version specification" - if {[string first - $versionspec] < 0} { - #no dash - #looks like a minbounded version (ie a single version with no dash) convert to min-max form - set from $versionspec - if {![tm_version_isvalid $from]} { - error "$errmsg '$versionpec'" - } - if {![catch {tm_version_major $from} majorv]} { - set from [tm_version_canonical $from] - return "${from}-[expr {$majorv +1}]" - } else { - error "$errmsg '$versionspec'" - } - } else { - # min- or min-max - #validation and canonicalisation (strip leading zeroes from each segment, including either side of a or b) - set parts [split $versionspec -] ;#we expect only 2 parts - lassign $parts from to - if {![tm_version_isvalid $from]} { - error "$errmsg '$versionspec'" - } - set from [tm_version_canonical $from] - if {[llength $parts] == 2} { - if {$to ne ""} { - if {![tm_version_isvalid $to]} { - error "$errmsg '$versionspec'" - } - set to [tm_version_canonical $to] - return $from-$to - } else { - return $from- - } - } else { - error "$errmsg '$versionspec'" - } - error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point" - } - } - # end tm_version... functions - # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == - - - - # -- --- - #https://stackoverflow.com/questions/17631269/whats-the-best-way-to-join-two-lists - #DKF's 2013 recommendation of using list {*}$first {*}$second seems not to apply in 2024 - #8.6,8.7,9.0 - 'lappend first {*}$second' is many times faster - especially as list grows - # Review and retest as new versions come out. - # -- --- - proc list_multi_append1 {lvar1 lvar2} { - #clear winner in 2024 - upvar $lvar1 l1 $lvar2 l2 - lappend l1 {*}$l2 - return $l1 - } - proc list_multi_append2 {lvar1 lvar2} { - upvar $lvar1 l1 $lvar2 l2 - set l1 [list {*}$l1 {*}$l2] - } - proc list_multi_append3 {lvar1 lvar2} { - upvar $lvar1 l1 $lvar2 l2 - set l1 [lindex [list [list {*}$l1 {*}$l2] [unset l1]] 0] - } - #testing e.g - #set l1_reset {a b c} - #set l2 {a b c d e f g} - #set l1 $l1_reset - #time {list_multi_append1 l1 l2} 1000 - #set l1 $l1_reset - #time {list_multi_append2 l1 l2} 1000 - # -- --- - - - proc lswap {lvar a z} { - upvar $lvar l - if {[lindex_resolve_basic $l $a] < 0 || [lindex_resolve_basic $l $z] < 0} { - #lindex_resolve_basic returns only -1 if out of range - #if we didn't do this check - we could raise an error on second lset below - leaving list corrupted because only one lset occurred - #(e.g using: lswap mylist end-2 end on a two element list) - - #on the unhapy path we can take time to check the nature of the out-of-boundness to give a nicer report - #use full 'lindex_resolve' which can report which side via -3 and -2 special results being lower and upper bound breaches respectively (-1 never returned) - set a_index [lindex_resolve $l $a] - set a_msg "" - switch -- $a_index { - -2 { - set a_msg "1st supplied index $a is above the upper bound for the list ([llength $l])" - } - -3 { - set a_msg "1st supplied index $a is below the lower bound for the list (0)" - } - } - set z_index [lindex_resolve $l $z] - set z_msg "" - switch -- $z_index { - -2 { - set z_msg "2nd supplied index $z is above the upper bound for the list ([llength $l])" - } - -3 { - set z_msg "2nd supplied index $z is below the lower bound for the list (0)" - } - } - set errmsg "lswap cannot swap indices $a and $z" - if {$a_msg ne ""} { - append errmsg \n $a_msg - } - if {$z_msg ne ""} { - append errmsg \n $z_msg - } - error $errmsg - } - set item2 [lindex $l $z] - lset l $z [lindex $l $a] - lset l $a $item2 - return $l - } - #proc lswap2 {lvar a z} { - # upvar $lvar l - # #if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower - # set l [concat [lrange $l 0 $a-1] [lindex $l $z] [lrange $l $a+1 $z-1] [lindex $l $a] [lrange $l $z+1 end]] - #} - - proc lswap2 {lvar a z} { - upvar $lvar l - #if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower - set l [list {*}[lrange $l 0 $a-1] [lindex $l $z] {*}[lrange $l $a+1 $z-1] [lindex $l $a] {*}[lrange $l $z+1 end]] - } - - #an experimental test of swapping vars without intermediate variables - #It's an interesting idea - but probably of little to no practical use - # - the swap_intvars3 version using intermediate var is faster in Tcl - # - This is probably unsurprising - as it's simpler code. - # Even if we tried this technique in c - the compiler would probably do a better job with the intermediate variable than with the math tricks. - #proc swap_intvars {swapv1 swapv2} { - # upvar $swapv1 _x $swapv2 _y - # set _x [expr {[expr {$_x + $_y}] - [set _y $_x]}] - #} - #proc swap_intvars2 {swapv1 swapv2} { - # upvar $swapv1 _x $swapv2 _y - # set _x [expr {$_x ^ $_y}] - # set _y [expr {$_x ^ $_y}] - # set _x [expr {$_x ^ $_y}] - #} - #proc swap_intvars3 {swapv1 swapv2} { - # #using intermediate variable - # upvar $swapv1 _x $swapv2 _y - # set z $_x - # set _x $_y - # set _y $z - #} - - #*** !doctools - #[subsection {Namespace punk::lib}] - #[para] Core API functions for punk::lib - #[list_begin definitions] - - if {[info commands lseq] ne ""} { - #tcl 8.7+ lseq significantly faster, especially for larger ranges - #The internal rep can be an 'arithseries' with no string representation - #support minimal set from to - proc range {from to} { - lseq $from $to - } - } else { - #lseq accepts basic expressions e.g 4-2 for both arguments - #e.g we can do lseq 0 [llength $list]-1 - #if range is to be consistent with the lseq version above - it should support that, even though we don't support most lseq functionality in either wrapper. - proc range {from to} { - set to [offset_expr $to] - set from [offset_expr $from] - if {$to > $from} { - set count [expr {($to -$from) + 1}] - if {$from == 0} { - return [lsearch -all [lrepeat $count 0] *] - } else { - incr from -1 - return [lmap v [lrepeat $count 0] {incr from}] - } - #slower methods. - #2) - #set i -1 - #set L [lrepeat $count 0] - #lmap v $L {lset L [incr i] [incr from];lindex {}} - #return $L - #3) - #set L {} - #for {set i 0} {$i < $count} {incr i} { - # lappend L [incr from] - #} - #return $L - } elseif {$from > $to} { - set count [expr {$from - $to} + 1] - #1) - if {$to == 0} { - return [lreverse [lsearch -all [lrepeat $count 0] *]] - } else { - incr from - return [lmap v [lrepeat $count 0] {incr from -1}] - } - - #2) - #set i -1 - #set L [lrepeat $count 0] - #lmap v $L {lset L [incr i] [incr from -1];lindex {}} - #return $L - #3) - #set L {} - #for {set i 0} {$i < $count} {incr i} { - # lappend L [incr from -1] - #} - #return $L - } else { - return [list $from] - } - } - } - - proc lzip {args} { - switch -- [llength $args] { - 0 {return {}} - 1 {return [lindex $args 0]} - 2 {return [lzip2lists {*}$args]} - 3 {return [lzip3lists {*}$args]} - 4 {return [lzip4lists {*}$args]} - 5 {return [lzip5lists {*}$args]} - 6 {return [lzip6lists {*}$args]} - 7 {return [lzip7lists {*}$args]} - 8 {return [lzip8lists {*}$args]} - 9 {return [lzip9lists {*}$args]} - 10 {return [lzip10lists {*}$args]} - 11 - 12 - 13 - 14 - 15 - 16 - 17 - 18 - 19 - 20 - 21 - 22 - 23 - 24 - 25 - 26 - 27 - 28 - 29 - 30 - 31 - 32 { - set n [llength $args] - if {[info commands ::punk::lib::lzip${n}lists] eq ""} { - puts "calling ::punk::lib::Build_lzipn $n" - ::punk::lib::Build_lzipn $n - } - return [lzip${n}lists {*}$args] - } - default { - if {[llength $args] < 4000} { - set n [llength $args] - if {[info commands ::punk::lib::lzip${n}lists] eq ""} { - puts "calling ::punk::lib::Build_lzipn $n" - ::punk::lib::Build_lzipn $n - } - return [lzip${n}lists {*}$args] - } else { - return [lzipn {*}$args] - } - } - } - } - - proc Build_lzipn {n} { - set arglist [list] - #use punk::lib::range which defers to lseq if available - set vars [lmap i [punk::lib::range 0 $n] {string cat v$i}] ;#v0 v1 v2.. (v0 ignored) - set body "\nlmap " - for {set i 1} {$i <= $n} {incr i} { - lappend arglist l$i - append body "[lindex $vars $i] \$l$i " - } - append body "\{list " - for {set i 1} {$i <= $n} {incr i} { - append body "\$[lindex $vars $i] " - } - append body "\}" \n - puts "proc punk::lib::lzip${n}lists {$arglist} \{" - puts "$body" - puts "\}" - proc ::punk::lib::lzip${n}lists $arglist $body - } - - #fastest is to know the number of lists to be zipped - proc lzip2lists {l1 l2} { - lmap a $l1 b $l2 {list $a $b} - } - proc lzip3lists {l1 l2 l3} { - lmap a $l1 b $l2 c $l3 {list $a $b $c} - } - proc lzip4lists {l1 l2 l3 l4} { - lmap a $l1 b $l2 c $l3 d $l4 {list $a $b $c $d} - } - proc lzip5lists {l1 l2 l3 l4 l5} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 {list $a $b $c $d $e} - } - proc lzip6lists {l1 l2 l3 l4 l5 l6} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 {list $a $b $c $d $e $f} - } - proc lzip7lists {l1 l2 l3 l4 l5 l6 l7} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 {list $a $b $c $d $e $f $g} - } - proc lzip8lists {l1 l2 l3 l4 l5 l6 l7 l8} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 {list $a $b $c $d $e $f $g $h} - } - proc lzip9lists {l1 l2 l3 l4 l5 l6 l7 l8 l9} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 {list $a $b $c $d $e $f $g $h $i} - } - proc lzip10lists {l1 l2 l3 l4 l5 l6 l7 l8 l9 l10} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 j $l10 {list $a $b $c $d $e $f $g $h $i $j} - } - - #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly - # review - - proc lzipn_alt args { - #stackoverflow - courtesy glenn jackman (modified) - foreach l $args { - lappend vars [incr n] - lappend lmap_args $n $l - } - lmap {*}$lmap_args {lmap v $vars {set $v}} - } - - #2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?) - proc lzipn_tcl8 {args} { - #wiki - courtesy JAL - set list_l $args - set zip_l [] - while {1} { - set cur [lmap a_l $list_l { lindex $a_l 0 }] - set list_l [lmap a_l $list_l { lrange $a_l 1 end }] - - if {[join $cur {}] eq {}} { - break - } - lappend zip_l $cur - } - return $zip_l - } - proc lzipn_tcl9a {args} { - #compared to wiki version - #comparable for lists len <3 or number of args < 3 - #approx 2x faster for large lists or more lists - #needs -stride single index bug fix to use empty string instead of NULL - if {![llength $args]} {return {}} - set lens [lmap l $args {llength $l}] - set numcolumns [::tcl::mathfunc::max {*}$lens] - set flatlist [lrepeat [expr {$numcolumns * [llength $args]}] {}] - set outlist [lrepeat $numcolumns {}] - set s 0 - foreach len $lens list $args { - #ledit flatlist $s $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] - ledit flatlist $s [expr {$s + $len - 1}] {*}$list - incr s $numcolumns - } - #needs single index lstride bugfix - for {set c 0} {$c < $numcolumns} {incr c} { - ledit outlist $c $c [lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *] - } - return $outlist - } - proc lzipn_tcl9b {args} { - if {![llength $args]} {return {}} - set lens [lmap l $args {llength $l}] - set numcolumns [::tcl::mathfunc::max {*}$lens] - set flatlist [list] - foreach len $lens list $args { - lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] - } - lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} - } - proc lzipn_tcl9c {args} { - #SLOW - if {![llength $args]} {return {}} - set lens [lmap l $args {llength $l}] - set numcolumns [::tcl::mathfunc::max {*}$lens] - set flatlist [list] - foreach len $lens list $args { - lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] - } - set zip_l {} - set cols_remaining $numcolumns - for {set c 0} {$c < $numcolumns} {incr c} { - if {$cols_remaining == 1} { - return [list {*}$zip_l $flatlist] - } - lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *] - set flen [llength $flatlist] - set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]] - incr cols_remaining -1 - } - return $zip_l - } - #keep both lzipn_tclX functions available for side-by-side testing in Tcl versions where it's possible - if {![package vsatisfies [package present Tcl] 9.0-] || [punk::lib::check::has_tclbug_lsearch_strideallinline ]} { - #-stride either not available - or has bug preventing use of main algorithm below - proc lzipn {args} [info body ::punk::lib::lzipn_tcl8] - } else { - proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a] - } - - - namespace import ::punk::args::lib::tstr - - - - proc invoke command { - #*** !doctools - #[call [fun invoke] [arg command]] - #[para]Invoke an external command (using tcl open command) capturing stdout,stderr and the exitcode - #[example { - # set script { - # puts stdout {hello on stdout} - # puts stderr {hello on stderr} - # exit 42 - # } - # invoke [list tclsh <<$script] - #}] - - #see https://wiki.tcl-lang.org/page/open - lassign [chan pipe] chanout chanin - lappend command 2>@$chanin - set fh [open |$command] - set stdout [read $fh] - close $chanin - set stderr [read $chanout] - close $chanout - if {[catch {close $fh} cres e]} { - dict with e {} - lassign [set -errorcode] sysmsg pid exit - if {$sysmsg eq {NONE}} { - #output to stderr caused [close] to fail. Do nothing - } elseif {$sysmsg eq {CHILDSTATUS}} { - return [list $stdout $stderr $exit] - } else { - return -options $e $stderr - } - } - return [list $stdout $stderr 0] - } - - proc pdict {args} { - package require punk::args - variable has_punk_ansi - if {!$has_punk_ansi} { - 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] { - @id -id ::punk::lib::pdict - @cmd -name pdict -help\ - "Print dict keys,values to channel - The pdict function operates on variable names - passing the value to the showdict function which operates on values - (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 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. - } - }] - #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 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 sep " [a+ Web-seagreen]=[a] " - variable has_punk_ansi - if {!$has_punk_ansi} { - set RST "" - set sep " = " - set sep_mismatch " mismatch " - } else { - set RST [punk::ansi::a] - set sep " [punk::ansi::a+ Green]=$RST " ;#stick to basic default colours for wider terminal support - set sep_mismatch " [punk::ansi::a+ Brightred undercurly underline undt-white]mismatch$RST " - } - package require punk::pipe - #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 -id ::punk::lib::showdict - @cmd -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_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 increasing -choices {increasing decreasing} - -debug -default 0 -type boolean -help\ - "When enabled, produces some rudimentary debug output on stderr" - @values -min 1 -max -1 - dictvalue -type list -help\ - "dict or list value" - patterns -default "*" -type string -multiple 1 -help\ - "key or key glob pattern" - }] $args] - - #for punk::lib - we want to reduce pkg dependencies. - # - so we won't even use the tcllib debug pkg here - set opt_debug [dict get $argd opts -debug] - if {$opt_debug} { - if {[info body debug::showdict] eq ""} { - proc ::punk::lib::debug::showdict {args} { - catch {puts stderr "punk::lib::showdict-> [string cat {*}$args]"} - } - } - } else { - if {[info body debug::showdict] ne ""} { - proc ::punk::lib::debug::showdict {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_keytemplates [dict get $argd opts -keytemplates] - debug::showdict "keytemplates ---> $opt_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] - 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 protect commas that appear within quotes) - set patterninfo [punk::pipe::lib::_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 - if {[string index $p 0] eq "!"} { - set get_not 1 - set p [string range $p 1 end] - } else { - set get_not 0 - } - 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 - } - # { - #todo get_not !# is test for listiness (see punk) - 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 "showdict ---->@*<----" - 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 - # } - #} - if {$get_not} { - lappend keyset [list !$p query] - } else { - 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 {$get_not} { - if {[dict exists $dval $k]} { - set keys [dict keys [dict remove $dval $k]] - lappend keyset {*}$keys - lappend keyset_structure {*}[lrepeat [llength $keys] dict] - } else { - lappend keyset {*}[dict keys $dval] - lappend keyset_structure {*}[lrepeat [dict size $dval] dict] - } - } else { - if {[dict exists $dval $k]} { - lappend keyset $k - lappend keyset_structure dict - } - } - dict set pattern_this_structure $p dict - } - @k@* - @K@* { - #TODO get_not - 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] - if {$get_not} { - lappend keyset [list !$p query] - } else { - lappend keyset [list $p query] - } - lappend keyset_structure dict - dict set pattern_this_structure $p dict - } - {@\*.@*} { - #TODO get_not - 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'" - if {$get_not} { - lappend keyset [list !$p query] - } else { - 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]} { - if {$get_not} { - set keys [punk::lib::range 0 [llength $dval]-1] - set keys [lremove $keys $p] - lappend keyset {*}$keys - lappend keyset_structure {*}[lrepeat [llength $keys] list] - } else { - 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} == -2} { - ##x - #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 == -3} { - ##x - set lower 0 - } else { - set lower $lower_resolve - } - set upper [punk::lib::lindex_resolve $dval $b] - if {$upper == -3} { - ##x - #upper bound is below list range - - if {$lower_resolve >=-2} { - ##x - set upper 0 - } else { - continue - } - } elseif {$upper == -2} { - #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] - if {$get_not} { - set fullrange [punk::lib::range 0 [llength $dval]-1] - set keys [lremove $fullrange {*}$keys] - if {$lower > $upper} { - set keys [lreverse $keys] - } - } - lappend keyset {*}$keys - lappend keyset_structure {*}[lrepeat [llength $keys] list] - } else { - if {$get_not} { - lappend keyset [list !@$p query] - } 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] - if {$get_not} { - set keys [dict keys [dict remove $dval {*}$keys]] - } - 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::pipe::lib::_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} { - #ignore the NOT operator for purposes of query-type detection - if {[string index $pnext 0] eq "!"} { - set pnext [string range $pnext 1 end] - } - # 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 { - 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 - 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 - - 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 - fix - #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 $keydisplay -width $maxl] $opt_sep "$opt_ansibase_values[dict get $dval $key]$RST"] \n - } - } - } - } - if {$opt_trimright} { - set result [::join [lines_as_list -line trimright $result] \n] - } - if {[string last \n $result] == [string length $result]-1} { - set result [string range $result 0 end-1] - } - #stdout/stderr can exist but not be in 'chan names' (e.g when transforms in place) - set chan [dict get $argd opts -channel] - switch -- $chan { - stderr - stdout { - puts $chan $result - } - none { - return $result - } - default { - #review - check member of chan names? - #just try outputting to the supplied channel for now - puts $chan $result - } - } - } - - proc is_list_all_in_list {small large} { - set small_in_large [lsort [struct::set intersect [lsort -unique $small] $large ]] - return [struct::list equal [lsort $small] $small_in_large] - } - if {!$has_struct_list || !$has_struct_set} { - set body { - package require struct::list - package require struct::set - } - append body [info body is_list_all_in_list] - proc is_list_all_in_list {small large} $body - } - - proc is_list_all_ni_list {a b} { - set i [struct::set intersect $a $b] - return [expr {[llength $i] == 0}] - } - if {!$has_struct_set} { - set body { - package require struct::list - } - append body [info body is_list_all_ni_list] - proc is_list_all_ni_list {a b} $body - } - - #somewhat like struct::set difference - but order preserving, and doesn't treat as a 'set' so preserves dupes in fromlist - #struct::set difference may happen to preserve ordering when items are integers, but order can't be relied on, - # especially as struct::set has 2 differing implementations (tcl vs critcl) which return results with different ordering to each other and different deduping behaviour in some cases (e.g empty 2nd arg) - proc ldiff {fromlist removeitems} { - if {[llength $removeitems] == 0} {return $fromlist} - set result {} - foreach item $fromlist { - if {$item ni $removeitems} { - lappend result $item - } - } - return $result - } - proc ldiff2 {fromlist removeitems} { - set doomed [list] - foreach item $removeitems { - lappend doomed {*}[lsearch -all -exact $fromlist $item] - } - lremove $fromlist {*}$doomed - } - - #fix for tcl impl of struct::set::diff which doesn't dedupe - proc struct_set_diff_unique {A B} { - package require struct::set ;#require even if tcl impl - so the dependency isn't missed accidentally due to Loaded state of programmers machine. - if {[struct::set::Loaded] eq "tcl"} { - return [punk::lib::setdiff $A $B] - } else { - #use (presumably critcl) implementation for speed - return [struct::set difference $A $B] - } - } - - - #non-dupe preserving - for consistency in dedupe behaviour we don't shortcircuit empty B - #consistent dedupe and order-maintenance of remaining items in A differentiate this from struct::set difference (dedupes with critcl, doesn't with tcl implementation 2024) - #also struct::set difference with critcl is faster - proc setdiff {A B} { - if {[llength $A] == 0} {return {}} - set d [dict create] - foreach x $A {dict set d $x {}} - foreach x $B {dict unset d $x} - return [dict keys $d] - } - #bulk dict remove is slower than a foreach with dict unset - #proc setdiff2 {fromlist removeitems} { - # #if {[llength $fromlist] == 0} {return {}} - # set d [dict create] - # foreach x $fromlist { - # dict set d $x {} - # } - # return [dict keys [dict remove $d {*}$removeitems]] - #} - #array is about 15% faster than dict - but unordered. (which is ok for sets - but we have struct::set for that) - proc setdiff_unordered {A B} { - if {[llength $A] == 0} {return {}} - array set tmp {} - foreach x $A {::set tmp($x) .} - foreach x $B {catch {unset tmp($x)}} - return [array names tmp] - } - - #default/fallback implementation - proc lunique_unordered {list} { - lunique $list - } - if {$has_struct_set} { - if {[struct::set equal [struct::set union {a a} {}] {a}]} { - proc lunique_unordered {list} { - struct::set union $list {} - } - } else { - puts stderr "WARNING: struct::set union no longer dedupes!" - #we could also test a sequence of: struct::set add - } - } - - - #order-preserving - proc lunique {list} { - set new {} - foreach item $list { - if {$item ni $new} { - lappend new $item - } - } - return $new - } - proc lunique2 {list} { - set doomed [list] - #expr 'in' probably faster than using a dict - for lists approx < 20,000 items. (wiki wisdom - url?) - for {set i 0} {$i < [llength $list]} {} { - set item [lindex $list $i] - lappend doomed {*}[lrange [lsearch -all -exact -start $i $list $item] 1 end] - while {[incr i] in $doomed} {} - } - lremove $list {*}$doomed - } - #The closure-like behaviour is *very* slow especially when called from a context such as the global namespace with lots of vars and large arrays such as ::env - proc lmapflat_closure {varnames list script} { - set result [list] - set values [list] - foreach v $varnames { - lappend values "\$$v" - } - # -- --- --- - #capture - use uplevel 1 or namespace eval depending on context - set capture [uplevel 1 { - apply { varnames { - set capturevars [tcl::dict::create] - set capturearrs [tcl::dict::create] - foreach fullv $varnames { - set v [tcl::namespace::tail $fullv] - upvar 1 $v var - if {[info exists var]} { - if {(![array exists var])} { - tcl::dict::set capturevars $v $var - } else { - tcl::dict::set capturearrs capturedarray_$v [array get var] - } - } else { - #A variable can show in the results for 'info vars' but still not 'exist'. e.g a 'variable x' declaration in the namespace where the variable has never been set - } - } - return [tcl::dict::create vars $capturevars arrs $capturearrs] - } } [info vars] - } ] - # -- --- --- - set cvars [tcl::dict::get $capture vars] - set carrs [tcl::dict::get $capture arrs] - set apply_script "" - foreach arrayalias [tcl::dict::keys $carrs] { - set realname [string range $arrayalias [string first _ $arrayalias]+1 end] - append apply_script [string map [list %realname% $realname %arrayalias% $arrayalias] { - array set %realname% [set %arrayalias%][unset %arrayalias%] - }] - } - - append apply_script [string map [list %script% $script] { - #foreach arrayalias [info vars capturedarray_*] { - # set realname [string range $arrayalias [string first _ $arrayalias]+1 end] - # array set $realname [set $arrayalias][unset arrayalias] - #} - #return [eval %script%] - %script% - }] - #puts "--> $apply_script" - foreach $varnames $list { - lappend result {*}[apply\ - [list\ - [concat $varnames [tcl::dict::keys $cvars] [tcl::dict::keys $carrs] ]\ - $apply_script\ - ] {*}[subst $values] {*}[tcl::dict::values $cvars] {*}[tcl::dict::values $carrs] ] - } - return $result - } - #link version - can write to vars in calling context - but keeps varnames themselves isolated - #performance much better than capture version - but still a big price to pay for the isolation - proc lmapflat_link {varnames list script} { - set result [list] - set values [list] - foreach v $varnames { - lappend values "\$$v" - } - set linkvars [uplevel 1 [list info vars]] - set nscaller [uplevel 1 [list namespace current]] - - set apply_script "" - foreach vname $linkvars { - append apply_script [string map [list %vname% $vname]\ - {upvar 2 %vname% %vname%}\ - ] \n - } - append apply_script $script \n - - #puts "--> $apply_script" - foreach $varnames $list { - lappend result {*}[apply\ - [list\ - $varnames\ - $apply_script\ - $nscaller\ - ] {*}[subst $values]\ - ] - } - return $result - } - - #proc lmapflat {varnames list script} { - # concat {*}[uplevel 1 [list lmap $varnames $list $script]] - #} - #lmap can accept multiple var list pairs - proc lmapflat {args} { - concat {*}[uplevel 1 [list lmap {*}$args]] - } - proc lmapflat2 {args} { - concat {*}[uplevel 1 lmap {*}$args] - } - - #proc dict_getdef {dictValue args} { - # if {[llength $args] < 1} { - # error {wrong # args: should be "dict_getdef dictValue ?key ...? key default"} - # } - # set keys [lrange $args -1 end-1] - # if {[tcl::dict::exists $dictValue {*}$keys]} { - # return [tcl::dict::get $dictValue {*}$keys] - # } else { - # return [lindex $args end] - # } - #} - if {[info commands ::tcl::dict::getdef] eq ""} { - proc dict_getdef {dictValue args} { - set keys [lrange $args 0 end-1] - if {[tcl::dict::exists $dictValue {*}$keys]} { - return [tcl::dict::get $dictValue {*}$keys] - } else { - return [lindex $args end] - } - } - } else { - #we pay a minor perf penalty for the wrap - interp alias "" ::punk::lib::dict_getdef "" ::tcl::dict::getdef - } - - - #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" - #} - - #supports *safe* ultra basic offset expressions as used by lindex etc, but without the 'end' features - #safe in that we don't evaluate the expression as a string. - proc offset_expr {expression} { - set expression [tcl::string::map {_ {}} $expression] - if {[tcl::string::is integer -strict $expression]} { - return [expr {$expression}] - } - if {[regexp {(.*)([+-])(.*)} $expression _match a op b] && [tcl::string::is integer -strict $a] && [tcl::string::is integer -strict $b]} { - if {$op eq "-"} { - return [expr {$a - $b}] - } else { - return [expr {$a + $b}] - } - } else { - error "bad expression '$expression': must be integer?\[+-\]integer?" - } - } - - # showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bunds on upper vs lower side - proc lindex_resolve {list index} { - #*** !doctools - #[call [fun lindex_resolve] [arg list] [arg index]] - #[para]Resolve an index which may be of the forms accepted by Tcl list commands such as end-2 or 2+2 to the actual integer index for the supplied list - #[para]Users may define procs which accept a list index and wish to accept the forms understood by Tcl. - #[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: - #[para] a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0) - #[para] b) -2 if the supplied index expression is above the upper bound for the supplied list. (> end) - #[para] We don't return -1 - as the similar function lindex_resolve_basic uses this to denote out of range at either end of the list - #[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 - #[para]For empty lists, end and end+x indices are considered to be out of bounds on the upper side - thus returning -2 - - #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]} { - # #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 -3 - } elseif {$index >= [llength $list]} { - return -2 - } else { - #integer may still have + sign - normalize with expr - return [expr {$index}] - } - } else { - if {[string match end* $index]} { - 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 -2 - } - } else { - #index is '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 -2 - } else { - return $index - } - } - if {$offset == 0} { - set index [expr {[llength $list]-1}] - if {$index < 0} { - return -2 ;#special case as above - } 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 -3 - } else { - return $index - } - } else { - #plain +- already handled above. - #we are trying to avoid evaluating unbraced expr of potentially insecure origin - 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?" - } - if {$index < 0} { - return -3 - } elseif {$index >= [llength $list]} { - return -2 - } - return $index - } - } - } - proc lindex_resolve_basic {list index} { - #*** !doctools - #[call [fun lindex_resolve_basic] [arg list] [arg index]] - #[para] Accepts index of the forms accepted by Tcl's list commands. (e.g compound indices such as 3+1 end-2) - #[para] returns -1 for out of range at either end, or a valid integer index - #[para] Unlike lindex_resolve; lindex_resolve_basic can't determine if an out of range index was out of range at the lower or upper bound - #[para] This is only likely to be faster than average over lindex_resolve for Tcl which has the builtin lseq command - #[para] The performance advantage is more likely to be present when using compound indexes such as $x+1 or end-1 - #[para] For pure integer indices the performance should be equivalent - - #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+ - # - which - #for {set i 0} {$i < [llength $list]} {incr i} { - # lappend indices $i - #} - set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 - if {[string is integer -strict $index]} { - #can match +i -i - #avoid even the lseq overhead when the index is simple - if {$index < 0 || ($index >= [llength $list])} { - #even though in this case we could return -2 or -3 like lindex_resolve; for consistency we don't, as it's not always determinable for compound indices using the lseq method. - return -1 - } else { - #integer may still have + sign - normalize with expr - return [expr {$index}] - } - } - if {[llength $list]} { - set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback. - #if lseq was available - $indices is an 'arithseries' - theoretically not taking up ram(?) - } else { - set indices [list] - } - set idx [lindex $indices $index] - if {$idx eq ""} { - #we have no way to determine if out of bounds is at lower vs upper end - return -1 - } else { - return $idx - } - } - proc lindex_get {list index} { - set resultlist [lrange $list $index $index] - if {![llength $resultlist]} { - return -1 - } else { - #we still don't know the actual integer index for an index such as end-x or int-int without parsing and evaluating ourself. - #we can return the value - but only in a way that won't collide with our -1 out-of-range indicator - return [tcl::dict::create value [lindex $resultlist 0]] - } - } - - - proc K {x y} {return $x} - #*** !doctools - #[call [fun K] [arg x] [arg y]] - #[para]The K-combinator function - returns the first argument, x and discards y - #[para]see [uri https://wiki.tcl-lang.org/page/K] - #[para]It is used in cases where command-substitution at the calling-point performs some desired effect. - - - proc is_utf8_multibyteprefix {bytes} { - #*** !doctools - #[call [fun is_utf8_multibyteprefix] [arg str]] - #[para] Returns a boolean if str is potentially a prefix for a multibyte utf-8 character - #[para] ie - tests if it is possible that appending more data will result in a utf-8 codepoint - #[para] Will return false for an already complete utf-8 codepoint - #[para] It is assumed the incomplete sequence is at the beginning of the bytes argument - #[para] Suitable input for this might be from the unreturned tail portion of get_utf8_leading $testbytes - #[para] e.g using: set head [lb]get_utf8_leading $testbytes[rb] ; set tail [lb]string range $testbytes [lb]string length $head[rb] end[rb] - regexp {(?x) - ^ - (?: - [\xC0-\xDF] | #possible prefix for two-byte codepoint - [\xE0-\xEF] [\x80-\xBF]{0,1} | #possible prefix for three-byte codepoint - [\xF0-\xF4] [\x80-\xBF]{0,2} #possible prefix for - ) - $ - } $bytes - } - - proc is_utf8_first {str} { - regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) - ^ - (?: - [\x00-\x7F] | # Single-byte chars (ASCII range) - [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) - [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) - [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) - ) - } $str - } - proc is_utf8_single {1234bytes} { - #*** !doctools - #[call [fun is_utf8_single] [arg 1234bytes]] - #[para] Tests input of 1,2,3 or 4 bytes and responds with a boolean indicating if it is a valid utf-8 character (codepoint) - regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) - ^ - (?: - [\x00-\x7F] | # Single-byte chars (ASCII range) - [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) - [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) - [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) - ) - $ - } $1234bytes - } - proc get_utf8_leading {rawbytes} { - #*** !doctools - #[call [fun get_utf8_leading] [arg rawbytes]] - #[para] return the leading portion of rawbytes that is a valid utf8 sequence. - #[para] This will stop at the point at which the bytes can't be interpreted as a complete utf-8 codepoint - #[para] e.g It will not return the first byte or 2 of a 3-byte utf-8 character if the last byte is missing, and will return only the valid utf-8 string from before the first byte of the incomplete character. - #[para] It will also only return the prefix before any bytes that cannot be part of a utf-8 sequence at all. - #[para] Note that while this will return valid utf8 - it has no knowledge of grapheme clusters or diacritics - #[para] This means if it is being used to process bytes split at some arbitrary point - the trailing data that isn't returned could be part of a grapheme cluster that belongs with the last character of the leading string already returned - #[para] The utf-8 BOM \xEF\xBB\xBF is a valid UTF8 3-byte sequence and so can also be returned as part of the leading utf8 bytes - if {[regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) - \A ( - [\x00-\x7F] | # Single-byte chars (ASCII range) - [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) - [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) - [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) - ) + - } $rawbytes completeChars]} { - return $completeChars - } - return "" - } - proc hex2dec {args} { - #*** !doctools - #[call [fun hex2dec] [opt {option value...}] [arg list_largeHex]] - #[para]Convert a list of (possibly large) unprefixed hex strings to their decimal values - #[para]hex2dec accepts and ignores internal underscores in the same manner as Tcl 8.7+ numbers e.g hex2dec FF_FF returns 65535 - #[para]Leading and trailing underscores are ignored as a matter of implementation convenience - but this shouldn't be relied upon. - #[para]Leading or trailing whitespace in each list member is allowed e.g hex2dec " F" returns 15 - #[para]Internal whitespace e.g "F F" is not permitted - but a completely empty element "" is allowed and will return 0 - - set list_largeHex [lindex $args end] - set argopts [lrange $args 0 end-1] - if {[llength $argopts]%2 !=0} { - error "[namespace current]::hex2dec arguments prior to list_largeHex must be option/value pairs - received '$argopts'" - } - set opts [tcl::dict::create\ - -validate 1\ - -empty_as_hex "INVALID set -empty_as_hex to a hex string e.g FF if empty values should be replaced"\ - ] - set known_opts [tcl::dict::keys $opts] - foreach {k v} $argopts { - tcl::dict::set opts [tcl::prefix match -message "options for hex2dec. Unexpected option" $known_opts $k] $v - } - # -- --- --- --- - set opt_validate [tcl::dict::get $opts -validate] - set opt_empty [tcl::dict::get $opts -empty_as_hex] - # -- --- --- --- - - set list_largeHex [lmap h $list_largeHex[unset list_largeHex] {string map {_ ""} [string trim $h]}] - if {$opt_validate} { - #Note appended F so that we accept list of empty strings as per the documentation - if {![string is xdigit -strict [join $list_largeHex ""]F ]} { - error "[namespace current]::hex2dec error: non-hex digits encountered after stripping underscores and leading/trailing whitespace for each element\n $list_largeHex" - } - } - if {![string is xdigit -strict [string map {_ ""} $opt_empty]]} { - #mapping empty string to a value destroys any advantage of -scanonly - #todo - document that -scanonly has 2 restrictions - each element must be valid hex and less than 7 chars long - #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {0} : {[set v]}}] - if {[lsearch $list_largeHex ""] >=0} { - error "[namespace current]::hex2dec error: empty values in list cannot be mapped to non-hex $opt_empty" - } - } else { - set opt_empty [string trim [string map {_ ""} $opt_empty]] - if {[set first_empty [lsearch $list_largeHex ""]] >= 0} { - #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {$opt_empty} : {$v}}] - set nonempty_head [lrange $list_largeHex 0 $first_empty-1] - set list_largeHex [concat $nonempty_head [lmap v [lrange $list_largeHex $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] - } - } - return [scan $list_largeHex [string repeat %llx [llength $list_largeHex]]] - } - - proc dec2hex {args} { - #*** !doctools - #[call [fun dex2hex] [opt {option value...}] [arg list_decimals]] - #[para]Convert a list of decimal integers to a list of hex values - #[para] -width can be used to make each hex value at least int characters wide, with leading zeroes. - #[para] -case upper|lower determines the case of the hex letters in the output - set list_decimals [lindex $args end] - set argopts [lrange $args 0 end-1] - if {[llength $argopts]%2 !=0} { - error "[namespace current]::dec2hex arguments prior to list_decimals must be option/value pairs - received '$argopts'" - } - set defaults [tcl::dict::create\ - -width 1\ - -case upper\ - -empty_as_decimal "INVALID set -empty_as_decimal to a number if empty values should be replaced"\ - ] - set known_opts [tcl::dict::keys $defaults] - set fullopts [tcl::dict::create] - foreach {k v} $argopts { - tcl::dict::set fullopts [tcl::prefix match -message "options for [tcl::namespace::current]::dec2hex. Unexpected option" $known_opts $k] $v - } - set opts [tcl::dict::merge $defaults $fullopts] - # -- --- --- --- - set opt_width [tcl::dict::get $opts -width] - set opt_case [tcl::dict::get $opts -case] - set opt_empty [tcl::dict::get $opts -empty_as_decimal] - # -- --- --- --- - - - set resultlist [list] - switch -- [string tolower $opt_case] { - upper { - set spec X - } - lower { - set spec x - } - default { - error "[namespace current]::dec2hex unknown value '$opt_case' for -case expected upper|lower" - } - } - set fmt "%${opt_width}.${opt_width}ll${spec}" - - set list_decimals [lmap d $list_decimals[unset list_decimals] {string map {_ ""} [string trim $d]}] - if {![string is digit -strict [string map {_ ""} $opt_empty]]} { - if {[lsearch $list_decimals ""] >=0} { - error "[namespace current]::dec2hex error: empty values in list cannot be mapped to non-decimal $opt_empty" - } - } else { - set opt_empty [string map {_ ""} $opt_empty] - if {[set first_empty [lsearch $list_decimals ""]] >= 0} { - set nonempty_head [lrange $list_decimals 0 $first_empty-1] - set list_decimals [concat $nonempty_head [lmap v [lrange $list_decimals $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] - } - } - return [format [lrepeat [llength $list_decimals] $fmt] {*}$list_decimals] - } - - proc log2 x "expr {log(\$x)/[expr log(2)]}" - #*** !doctools - #[call [fun log2] [arg x]] - #[para]log base2 of x - #[para]This uses a 'live' proc body - the divisor for the change of base is computed once at definition time - #[para](courtesy of RS [uri https://wiki.tcl-lang.org/page/Additional+math+functions]) - - proc logbase {b x} { - #*** !doctools - #[call [fun logbase] [arg b] [arg x]] - #[para]log base b of x - #[para]This function uses expr's natural log and the change of base division. - #[para]This means for example that we can get results like: logbase 10 1000 = 2.9999999999999996 - #[para]Use expr's log10() function or tcl::mathfunc::log10 for base 10 - expr {log($x)/log($b)} - } - proc factors {x} { - #*** !doctools - #[call [fun factors] [arg x]] - #[para]Return a sorted list of the positive factors of x where x > 0 - #[para]For x = 0 we return only 0 and 1 as technically any number divides zero and there are an infinite number of factors. (including zero itself in this context)* - #[para]This is a simple brute-force implementation that iterates all numbers below the square root of x to check the factors - #[para]Because the implementation is so simple - the performance is very reasonable for numbers below at least a few 10's of millions - #[para]See tcllib math::numtheory::factors for a more complex implementation - which seems to be slower for 'small' numbers - #[para]Comparisons were done with some numbers below 17 digits long - #[para]For seriously big numbers - this simple algorithm would no doubt be outperformed by more complex algorithms. - #[para]The numtheory library stores some data about primes etc with each call - so may become faster when being used on more numbers - #but has the disadvantage of being slower for 'small' numbers and using more memory. - #[para]If the largest factor below x is needed - the greatestOddFactorBelow and GreatestFactorBelow functions are a faster way to get there than computing the whole list, even for small values of x - #[para]* Taking x=0; Notion of x being divisible by integer y being: There exists an integer p such that x = py - #[para] In other mathematical contexts zero may be considered not to divide anything. - set factors [list 1] - set j 2 - set max [expr {sqrt($x)}] - while {$j <= $max} { - if {($x % $j) == 0} { - lappend factors $j [expr {$x / $j}] - } - incr j - } - lappend factors $x - return [lsort -unique -integer $factors] - } - proc oddFactors {x} { - #*** !doctools - #[call [fun oddFactors] [arg x]] - #[para]Return a list of odd integer factors of x, sorted in ascending order - set j 2 - set max [expr {sqrt($x)}] - set factors [list 1] - while {$j <= $max} { - if {$x % $j == 0} { - set other [expr {$x / $j}] - if {$other % 2} { - if {$other ni $factors} { - lappend factors $other - } - } - if {$j % 2} { - if {$j ni $factors} { - lappend factors $j - } - } - } - incr j - } - return [lsort -integer -increasing $factors] - } - proc greatestFactorBelow {x} { - #*** !doctools - #[call [fun greatestFactorBelow] [arg x]] - #[para]Return the largest factor of x excluding itself - #[para]factor functions can be useful for console layout calculations - #[para]See Tcllib math::numtheory for more extensive implementations - if {$x % 2 == 0 || $x == 0} { - return [expr {$x / 2}] - } - set j 3 - set max [expr {sqrt($x)}] - while {$j <= $max} { - if {$x % $j == 0} { - return [expr {$x / $j}] - } - incr j 2 - } - return 1 - } - proc greatestOddFactorBelow {x} { - #*** !doctools - #[call [fun greatestOddFactorBelow] [arg x]] - #[para]Return the largest odd integer factor of x excluding x itself - if {$x %2 == 0} { - return [greatestOddFactor $x] - } - set j 3 - #dumb brute force - time taken to compute is wildly variable on big numbers - #todo - use a (memoized?) generator of primes to reduce the search space - #tcllib math::numtheory has suitable functions - but do we want that dependency here? Testing shows brute-force often faster for small numbers. - set god 1 - set max [expr {sqrt($x)}] - while { $j <= $max} { - if {$x % $j == 0} { - set other [expr {$x / $j}] - if {$other % 2 == 0} { - set god $j - } else { - set god [expr {$x / $j}] - #lowest j - so other side must be highest - break - } - } - incr j 2 - } - return $god - } - proc greatestOddFactor {x} { - #*** !doctools - #[call [fun greatestOddFactor] [arg x]] - #[para]Return the largest odd integer factor of x - #[para]For an odd value of x - this will always return x - if {$x % 2 != 0 || $x == 0} { - return $x - } - set r [expr {$x / 2}] - while {$r % 2 == 0} { - set r [expr {$r / 2}] - } - return $r - } - proc gcd {n m} { - #*** !doctools - #[call [fun gcd] [arg n] [arg m]] - #[para]Return the greatest common divisor of m and n - #[para]Straight from Lars Hellström's math::numtheory library in Tcllib - #[para]Graphical use: - #[para]An a by b rectangle can be covered with square tiles of side-length c, - #[para]only if c is a common divisor of a and b - - # - # Apply Euclid's good old algorithm - # - if { $n > $m } { - set t $n - set n $m - set m $t - } - - while { $n > 0 } { - set r [expr {$m % $n}] - set m $n - set n $r - } - - return $m - } - proc lcm {n m} { - #*** !doctools - #[call [fun gcd] [arg n] [arg m]] - #[para]Return the lowest common multiple of m and n - #[para]Straight from Lars Hellström's math::numtheory library in Tcllib - #[para] - set gcd [gcd $n $m] - return [expr {$n*$m/$gcd}] - } - proc commonDivisors {x y} { - #*** !doctools - #[call [fun commonDivisors] [arg x] [arg y]] - #[para]Return a list of all the common factors of x and y - #[para](equivalent to factors of their gcd) - return [factors [gcd $x $y]] - } - - #experimental only - there are better/faster ways - proc sieve n { - set primes [list] - if {$n < 2} {return $primes} - set nums [tcl::dict::create] - for {set i 2} {$i <= $n} {incr i} { - tcl::dict::set nums $i "" - } - set next 2 - set limit [expr {sqrt($n)}] - while {$next <= $limit} { - for {set i $next} {$i <= $n} {incr i $next} {tcl::dict::unset nums $i} - lappend primes $next - tcl::dict::for {next -} $nums break - } - return [concat $primes [tcl::dict::keys $nums]] - } - proc sieve2 n { - set primes [list] - if {$n < 2} {return $primes} - set nums [tcl::dict::create] - for {set i 2} {$i <= $n} {incr i} { - tcl::dict::set nums $i "" - } - set next 2 - set limit [expr {sqrt($n)}] - while {$next <= $limit} { - for {set i $next} {$i <= $n} {incr i $next} {tcl::dict::unset nums $i} - lappend primes $next - #dict for {next -} $nums break - set next [lindex $nums 0] - } - return [concat $primes [tcl::dict::keys $nums]] - } - - proc hasglobs {str} { - #*** !doctools - #[call [fun hasglobs] [arg str]] - #[para]Return a boolean indicating whether str contains any of the glob characters: * ? [lb] [rb] - #[para]hasglobs uses append to preserve Tcls internal representation for str - so it should help avoid shimmering in the few cases where this may matter. - regexp {[*?\[\]]} [append obj2 $str {}] ;# int-rep preserving - } - - proc trimzero {number} { - #*** !doctools - #[call [fun trimzero] [arg number]] - #[para]Return number with left-hand-side zeros trimmed off - unless all zero - #[para]If number is all zero - a single 0 is returned - set trimmed [string trimleft $number 0] - if {[string length $trimmed] == 0} { - set trimmed 0 - } - return $trimmed - } - proc substring_count {str substring} { - #*** !doctools - #[call [fun substring_count] [arg str] [arg substring]] - #[para]Search str and return number of occurrences of substring - - #faster than lsearch on split for str of a few K - if {$substring eq ""} {return 0} - set occurrences [expr {[string length $str]-[string length [string map [list $substring {}] $str]]}] - return [expr {$occurrences / [string length $substring]}] - } - - proc dict_merge_ordered {defaults main} { - #*** !doctools - #[call [fun dict_merge_ordered] [arg defaults] [arg main]] - #[para]The standard dict merge accepts multiple dicts with values from dicts to the right (2nd argument) taking precedence. - #[para]When merging with a dict of default values - this means that any default key/vals that weren't in the main dict appear in the output before the main data. - #[para]This function merges the two dicts whilst maintaining the key order of main followed by defaults. - - #1st merge (inner merge) with wrong values taking precedence - but right key-order - then (outer merge) restore values - return [tcl::dict::merge [tcl::dict::merge $main $defaults] $main] - } - - proc askuser {question} { - #*** !doctools - #[call [fun askuser] [arg question]] - #[para]A basic utility to read an answer from stdin - #[para]The prompt is written to the terminal and then it waits for a user to type something - #[para]stdin is temporarily configured to blocking and then put back in its original state in case it wasn't already so. - #[para]If the terminal is using punk::console and is in raw mode - the terminal will temporarily be put in line mode. - #[para](Generic terminal raw vs linemode detection not yet present) - #[para]The user must hit enter to submit the response - #[para]The return value is the string if any that was typed prior to hitting enter. - #[para]The question argument can be manually colourised using the various punk::ansi funcitons - #[example_begin] - # set answer [lb]punk::lib::askuser "[lb]a+ green bold[rb]Do you want to proceed? (Y|N)[lb]a[rb]"[rb] - # if {[lb]string match y* [lb]string tolower $answer[rb][rb]} { - # puts "Proceeding" - # } else { - # puts "Cancelled by user" - # } - #[example_end] - puts stdout $question - flush stdout - set stdin_state [chan configure stdin] - if {[catch { - package require punk::console - set console_raw [tsv::get console is_raw] - } err_console]} { - #assume normal line mode - set console_raw 0 - } - try { - chan configure stdin -blocking 1 - if {$console_raw} { - punk::console::disableRaw - set answer [gets stdin] - punk::console::enableRaw - } else { - set answer [gets stdin] - } - } finally { - chan configure stdin -blocking [tcl::dict::get $stdin_state -blocking] - } - return $answer - } - - #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. - proc indent {text {prefix " "}} { - set result [list] - foreach line [split $text \n] { - if {[string trim $line] eq ""} { - lappend result "" - } else { - lappend result $prefix[string trimright $line] - } - } - return [join $result \n] - } - #dedent? - proc undent {text} { - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - regexp {^([\t ]*)} $lcp _m lcp - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - #A version of textutil::string::longestCommonPrefixList - proc longestCommonPrefix {items} { - if {[llength $items] <= 1} { - return [lindex $items 0] - } - set items [lsort $items[unset items]] - set min [lindex $items 0] - set max [lindex $items end] - #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) - #(sort order nothing to do with length - e.g min may be longer than max) - if {[string length $min] > [string length $max]} { - set temp $min - set min $max - set max $temp - } - set n [string length $min] - set prefix "" - set i -1 - while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { - append prefix $c - } - return $prefix - } - - #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 - #[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 ? " - } - 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 [tcl::dict::values [punk::args::get_dict { - -joinchar -default \n - @values -min 1 -max 1 - } $args]] leaders opts values - puts "opts:$opts" - puts "values:$values" - return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]] - } - - proc lines_as_list {args} { - #*** !doctools - #[call [fun lines_as_list] [opt {option value ...}] [arg text]] - #[para]Returns a list of possibly trimmed lines depeding on options - #[para]The concept of lines is raw lines from splitting on newline after crlf is mapped to lf - #[para]- not console lines which may be entirely different due to control characters such as vertical tabs or ANSI movements - - #The underlying function linelist has the validation code which gives nicer 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 [tcl::dict::merge {-block {}} $opts] - set bposn [lsearch $opts -block] - if {$bposn < 0} { - lappend opts -block {} - } - set text [lindex $args end] - #tailcall linelist {*}$opts $text - return [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 [tcl::dict::values [punk::args::get_dict { - @opts -any 1 - -block -default {} - } $args]] leaderdict opts valuedict - tailcall linelist {*}$opts {*}[tcl::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 - set linelist_body { - set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" - if {[llength $args] == 0} { - error "linelist missing textchunk argument usage:$usage" - } - set text [lindex $args end] - set text [string map {\r\n \n} $text] ;#review - option? - - set arglist [lrange $args 0 end-1] - set opts [tcl::dict::create\ - -block {trimhead1 trimtail1}\ - -line {}\ - -commandprefix ""\ - -ansiresets auto\ - -ansireplays 0\ - ] - foreach {o v} $arglist { - switch -- $o { - -block - -line - -commandprefix - -ansiresets - -ansireplays { - tcl::dict::set opts $o $v - } - default { - error "linelist: Unrecognized option '$o' usage:$usage" - } - } - } - # -- --- --- --- --- --- - set opt_block [tcl::dict::get $opts -block] - if {[llength $opt_block]} { - foreach bo $opt_block { - switch -- $bo { - trimhead - trimtail - triminner - trimall - trimhead1 - trimtail1 - collateempty {} - default { - set known_blockopts [list trimhead trimtail triminner trimall trimhead1 trimtail1 collateempty] - error "linelist: unknown -block option value: $bo known values: $known_blockopts" - } - } - } - #normalize certain combos - if {"trimhead" in $opt_block && [set posn [lsearch $opt_block trimhead1]] >=0} { - set opt_block [lreplace $opt_block $posn $posn] - } - if {"trimtail" in $opt_block && [set posn [lsearch $opt_block trimtail1]] >=0} { - 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 [tcl::dict::get $opts -line] - set tl_left 0 - set tl_right 0 - set tl_both 0 - foreach lo $opt_line { - switch -- $lo { - trimline { - set tl_both 1 - } - trimleft { - set tl_left 1 - } - trimright { - set tl_right 1 - } - default { - set known_lineopts [list trimline trimleft trimright] - error "linelist: unknown -line option value: $lo known values: $known_lineopts" - } - } - } - #normalize trimleft trimright combo - if {$tl_left && $tl_right} { - set opt_line [list "trimline"] - set tl_both 1 - } - # -- --- --- --- --- --- - set opt_commandprefix [tcl::dict::get $opts -commandprefix] - # -- --- --- --- --- --- - set opt_ansiresets [tcl::dict::get $opts -ansiresets] - # -- --- --- --- --- --- - set opt_ansireplays [tcl::dict::get $opts -ansireplays] - if {$opt_ansireplays} { - if {$opt_ansiresets eq "auto"} { - set opt_ansiresets 1 - } - } else { - if {$opt_ansiresets eq "auto"} { - set opt_ansiresets 0 - } - } - # -- --- --- --- --- --- - set linelist [list] - set nlsplit [split $text \n] - if {![llength $opt_line]} { - set linelist $nlsplit - #lappend linelist {*}$nlsplit - } else { - #already normalized trimleft+trimright to trimline - if {$tl_both} { - foreach ln $nlsplit { - lappend linelist [string trim $ln] - } - } elseif {$tl_left} { - foreach ln $nlsplit { - lappend linelist [string trimleft $ln] - } - } elseif {$tl_right} { - foreach ln $nlsplit { - 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] - } - - #review - we need to make sure ansiresets don't accumulate/grow on any line - #Each resulting line should have a reset of some type at start and a pure-reset at end to stop - #see if we can find an ST sequence that most terminals will not display for marking sections? - if {$opt_ansireplays} { - #package require punk::ansi - - if {$opt_ansiresets} { - set RST "\x1b\[0m" - } else { - set RST "" - } - set replaycodes $RST ;#todo - default? - set transformed [list] - #shortcircuit common case of no ansi - #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. - #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) - #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable - #detect_in_list will check at first level. (not intended for detecting ansi in deeper structures) - if {![punk::ansi::ta::detect_in_list $linelist]} { - if {$opt_ansiresets} { - foreach ln $linelist { - lappend transformed $RST$ln$RST - } - set linelist $transformed - } - } else { - - #INLINE punk::ansi::codetype::is_sgr_reset - #regexp {\x1b\[0*m$} $code - set re_is_sgr_reset {\x1b\[0*m$} - #INLINE punk::ansi::codetype::is_sgr - #regexp {\033\[[0-9;:]*m$} $code - set re_is_sgr {\x1b\[[0-9;:]*m$} - - foreach ln $linelist { - #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable - - #set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. - #get_codes_single lists only the codes. no plaintext or empty elements - set ansisplits [punk::ansi::ta::get_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. - if {[llength $ansisplits] == 0} { - #plaintext only - no ansi codes in line - lappend transformed [string cat $replaycodes $ln $RST] - #leave replaycodes as is for next line - set nextreplay $replaycodes - } else { - set tail $RST - set lastcode [lindex $ansisplits end] ;#may or may not be SGR - set lastcodeoffset [expr {[string length $lastcode]-1}] - if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { - if {[string range $ln end-$lastcodeoffset end] eq $lastcode} { - #last plaintext is empty. So the line is already suffixed with a reset - set tail "" - set nextreplay $RST - } else { - #trailing text has been reset within line - but no tail reset present - #we normalize by putting a tail reset on anyway - set tail $RST - set nextreplay $RST - } - } elseif {[string range $ln end-$lastcodeoffset end] eq $lastcode && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { - #code is at tail (no trailing plaintext) - #No tail reset - and no need to examine whole line to determine stack that is in effect - set tail $RST - set nextreplay $lastcode - } else { - #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect - #last codeset doesn't end in a pure-reset - #whether code was at very end or not - add a reset tail - set tail $RST - #determine effective replay for line - set codestack [list start] - foreach code $ansisplits { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set codestack [list] ;#different from 'start' marked - this means we've had a reset - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set codestack [list $code] - } else { - if {[punk::ansi::codetype::is_sgr $code]} { - #todo - proper test of each code - so we only take latest background/foreground etc. - #requires handling codes with varying numbers of parameters. - #basic simplification - remove straight dupes. - set dup_posns [lsearch -all -exact $codestack $code] ;#!must use -exact as codes have square brackets which are interpreted as glob chars. - set codestack [lremove $codestack {*}$dup_posns] - lappend codestack $code - } ;#else gx0 or other code - we don't want to stack it with SGR codes - } - } - if {$codestack eq [list start]} { - #No SGRs - may have been other codes - set line_has_sgr 0 - } else { - #list is either empty or begins with start - empty means it had SGR reset - so it still invalidates current state of replaycodes - set line_has_sgr 1 - if {[lindex $codestack 0] eq "start"} { - set codestack [lrange $codestack 1 end] - } - } - - #set newreplay [join $codestack ""] - set newreplay [punk::ansi::codetype::sgr_merge_list {*}$codestack] - - if {$line_has_sgr && $newreplay ne $replaycodes} { - #adjust if it doesn't already does a reset at start - if {[punk::ansi::codetype::has_sgr_leadingreset $newreplay]} { - set nextreplay $newreplay - } else { - set nextreplay $RST$newreplay - } - } else { - set nextreplay $replaycodes - } - } - if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { - #no point attaching any replay - lappend transformed [string cat $ln $tail] - } else { - lappend transformed [string cat $replaycodes $ln $tail] - } - } - set replaycodes $nextreplay - } - set linelist $transformed - } - } - - if {[llength $opt_commandprefix]} { - set transformed [list] - foreach ln $linelist { - lappend transformed [{*}$opt_commandprefix $ln] - } - set linelist $transformed - } - - return $linelist - } - if {$has_punk_ansi} { - #optimise linelist as much as possible - set linelist_body [string map { ""} $linelist_body] - } else { - #punk ansi not avail at time of package load. - #by putting in calls to punk::ansi the user will get appropriate error messages - set linelist_body [string map { "package require punk::ansi"} $linelist_body] - } - - set linelist_body_original { - set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" - if {[llength $args] == 0} { - error "linelist missing textchunk argument usage:$usage" - } - set text [lindex $args end] - set text [string map {\r\n \n} $text] ;#review - option? - - set arglist [lrange $args 0 end-1] - set opts [tcl::dict::create\ - -block {trimhead1 trimtail1}\ - -line {}\ - -commandprefix ""\ - -ansiresets auto\ - -ansireplays 0\ - ] - foreach {o v} $arglist { - switch -- $o { - -block - -line - -commandprefix - -ansiresets - -ansireplays { - tcl::dict::set opts $o $v - } - default { - error "linelist: Unrecognized option '$o' usage:$usage" - } - } - } - # -- --- --- --- --- --- - set opt_block [tcl::dict::get $opts -block] - if {[llength $opt_block]} { - foreach bo $opt_block { - switch -- $bo { - trimhead - trimtail - triminner - trimall - trimhead1 - trimtail1 - collateempty {} - default { - set known_blockopts [list trimhead trimtail triminner trimall trimhead1 trimtail1 collateempty] - error "linelist: unknown -block option value: $bo known values: $known_blockopts" - } - } - } - #normalize certain combos - if {"trimhead" in $opt_block && [set posn [lsearch $opt_block trimhead1]] >=0} { - set opt_block [lreplace $opt_block $posn $posn] - } - if {"trimtail" in $opt_block && [set posn [lsearch $opt_block trimtail1]] >=0} { - 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 [tcl::dict::get $opts -line] - set tl_left 0 - set tl_right 0 - set tl_both 0 - foreach lo $opt_line { - switch -- $lo { - trimline { - set tl_both 1 - } - trimleft { - set tl_left 1 - } - trimright { - set tl_right 1 - } - default { - set known_lineopts [list trimline trimleft trimright] - error "linelist: unknown -line option value: $lo known values: $known_lineopts" - } - } - } - #normalize trimleft trimright combo - if {$tl_left && $tl_right} { - set opt_line [list "trimline"] - set tl_both 1 - } - # -- --- --- --- --- --- - set opt_commandprefix [tcl::dict::get $opts -commandprefix] - # -- --- --- --- --- --- - set opt_ansiresets [tcl::dict::get $opts -ansiresets] - # -- --- --- --- --- --- - set opt_ansireplays [tcl::dict::get $opts -ansireplays] - if {$opt_ansireplays} { - if {$opt_ansiresets eq "auto"} { - set opt_ansiresets 1 - } - } else { - if {$opt_ansiresets eq "auto"} { - set opt_ansiresets 0 - } - } - # -- --- --- --- --- --- - set linelist [list] - set nlsplit [split $text \n] - if {![llength $opt_line]} { - set linelist $nlsplit - #lappend linelist {*}$nlsplit - } else { - #already normalized trimleft+trimright to trimline - if {$tl_both} { - foreach ln $nlsplit { - lappend linelist [string trim $ln] - } - } elseif {$tl_left} { - foreach ln $nlsplit { - lappend linelist [string trimleft $ln] - } - } elseif {$tl_right} { - foreach ln $nlsplit { - 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] - } - - #review - we need to make sure ansiresets don't accumulate/grow on any line - #Each resulting line should have a reset of some type at start and a pure-reset at end to stop - #see if we can find an ST sequence that most terminals will not display for marking sections? - if {$opt_ansireplays} { - #package require punk::ansi - - if {$opt_ansiresets} { - set RST "\x1b\[0m" - } else { - set RST "" - } - set replaycodes $RST ;#todo - default? - set transformed [list] - #shortcircuit common case of no ansi - #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. - #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) - #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable - #detect_in_list will check at first level. (not intended for detecting ansi in deeper structures) - if {![punk::ansi::ta::detect_in_list $linelist]} { - if {$opt_ansiresets} { - foreach ln $linelist { - lappend transformed $RST$ln$RST - } - set linelist $transformed - } - } else { - - #INLINE punk::ansi::codetype::is_sgr_reset - #regexp {\x1b\[0*m$} $code - set re_is_sgr_reset {\x1b\[0*m$} - #INLINE punk::ansi::codetype::is_sgr - #regexp {\033\[[0-9;:]*m$} $code - set re_is_sgr {\x1b\[[0-9;:]*m$} - - foreach ln $linelist { - #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable - - set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. - if {[llength $ansisplits]<= 1} { - #plaintext only - no ansi codes in line - lappend transformed [string cat $replaycodes $ln $RST] - #leave replaycodes as is for next line - set nextreplay $replaycodes - } else { - set tail $RST - set lastcode [lindex $ansisplits end-1] ;#may or may not be SGR - if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { - if {[lindex $ansisplits end] eq ""} { - #last plaintext is empty. So the line is already suffixed with a reset - set tail "" - set nextreplay $RST - } else { - #trailing text has been reset within line - but no tail reset present - #we normalize by putting a tail reset on anyway - set tail $RST - set nextreplay $RST - } - } elseif {[lindex $ansisplits end] ne "" && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { - #No tail reset - and no need to examine whole line to determine stack that is in effect - set tail $RST - set nextreplay $lastcode - } else { - #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect - #last codeset doesn't end in a pure-reset - #whether code was at very end or not - add a reset tail - set tail $RST - #determine effective replay for line - set codestack [list start] - foreach {pt code} $ansisplits { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set codestack [list] ;#different from 'start' marked - this means we've had a reset - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set codestack [list $code] - } else { - if {[punk::ansi::codetype::is_sgr $code]} { - #todo - proper test of each code - so we only take latest background/foreground etc. - #requires handling codes with varying numbers of parameters. - #basic simplification - remove straight dupes. - set dup_posns [lsearch -all -exact $codestack $code] ;#!must use -exact as codes have square brackets which are interpreted as glob chars. - set codestack [lremove $codestack {*}$dup_posns] - lappend codestack $code - } ;#else gx0 or other code - we don't want to stack it with SGR codes - } - } - if {$codestack eq [list start]} { - #No SGRs - may have been other codes - set line_has_sgr 0 - } else { - #list is either empty or begins with start - empty means it had SGR reset - so it still invalidates current state of replaycodes - set line_has_sgr 1 - if {[lindex $codestack 0] eq "start"} { - set codestack [lrange $codestack 1 end] - } - } - - #set newreplay [join $codestack ""] - set newreplay [punk::ansi::codetype::sgr_merge_list {*}$codestack] - - if {$line_has_sgr && $newreplay ne $replaycodes} { - #adjust if it doesn't already does a reset at start - if {[punk::ansi::codetype::has_sgr_leadingreset $newreplay]} { - set nextreplay $newreplay - } else { - set nextreplay $RST$newreplay - } - } else { - set nextreplay $replaycodes - } - } - if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { - #no point attaching any replay - lappend transformed [string cat $ln $tail] - } else { - lappend transformed [string cat $replaycodes $ln $tail] - } - } - set replaycodes $nextreplay - } - set linelist $transformed - } - } - - if {[llength $opt_commandprefix]} { - set transformed [list] - foreach ln $linelist { - lappend transformed [{*}$opt_commandprefix $ln] - } - set linelist $transformed - } - - return $linelist - } - if {$has_punk_ansi} { - #optimise linelist as much as possible - set linelist_body [string map { ""} $linelist_body] - } else { - #punk ansi not avail at time of package load. - #by putting in calls to punk::ansi the user will get appropriate error messages - set linelist_body [string map { "package require punk::ansi"} $linelist_body] - } - proc linelist {args} $linelist_body - - - interp alias {} errortime {} punk::lib::errortime - proc errortime {script groupsize {iters 2}} { - #by use MAK from https://wiki.tcl-lang.org/page/How+to+Measure+Performance - set i 0 - set times {} - if {$iters < 2} {set iters 2} - - for {set i 0} {$i < $iters} {incr i} { - set result [uplevel [list time $script $groupsize]] - lappend times [lindex $result 0] - } - - set average 0.0 - set s2 0.0 - - foreach time $times { - set average [expr {$average + double($time)/$iters}] - } - - foreach time $times { - set s2 [expr {$s2 + (($time-$average)*($time-$average) / ($iters-1))}] - } - - set sigma [expr {int(sqrt($s2))}] - set average [expr {int($average)}] - - return "$average +/- $sigma microseconds per iteration" - } - - #test function to use with show_jump_tables - #todo - check if switch compilation to jump tables differs by Tcl version - proc switch_char_test {c} { - set dec [scan $c %c] - foreach t [list 1 2 3] { - switch -- $c { - x { - return [list $dec x $t] - } - y { - return [list $dec y $t] - } - z { - return [list $dec z $t] - } - } - } - - #tcl 8.6/8.7 (at least) - #curlies must be unescaped and unbraced to work as literals in switch and enable it to compile to jumpTable - switch -- $c { - a { - return [list $dec a] - } - {"} { - return [list $dec dquote] - } - {[} {return [list $dec lb]} - {]} {return [list $dec rb]} - "{" { - return [list $dec lbrace] - } - "}" { - return [list $dec rbrace] - } - default { - return [list $dec $c] - } - } - - - - } - - #we are interested in seeing jumpTable line and following lines up until next line starting with "Command" or bracketed number e.g (164) - proc show_jump_tables {args} { - #avoiding use of 'info cmdtype' as unavaliable in safe interps as at 2024-06. - if {[llength $args] == 1} { - set data [tcl::unsupported::disassemble proc [lindex $args 0]] - } elseif {[llength $args] == 2} { - #review - this looks for direct methods on the supplied object/class, and then tries to disassemble method on the supplied class or class of supplied object if it isn't a class itself. - #not sure if this handles more complex hierarchies or mixins etc. - lassign $args obj method - if {![info object isa object $obj]} { - error "show_jump_tables unable to examine '$args'. $obj is not an oo object" - } - #classes are objects too and can have direct methods - if {$method in [info object methods $obj]} { - set data [tcl::unsupported::disassemble objmethod $obj $method] - } else { - if {![info object isa class $obj]} { - set obj [info object class $obj] - } - set data [tcl::unsupported::disassemble method $obj $method] - } - } else { - error "show_jump_tables expected a procname or a class/object and method" - } - set result "" - set in_jt 0 - foreach ln [split $data \n] { - set tln [string trim $ln] - if {!$in_jt} { - if {[string match *jumpTable* $ln]} { - append result $ln \n - set in_jt 1 - } - } else { - if {[string match Command* $tln] || [string match "(*) *" $tln]} { - set in_jt 0 - } else { - append result $ln \n - } - } - } - return $result - } - - proc temperature_f_to_c {deg_fahrenheit} { - return [expr {($deg_fahrenheit -32) * (5/9.0)}] - } - proc temperature_c_to_f {deg_celsius} { - return [expr {($deg_celsius * (9/5.0)) + 32}] - } - - proc interp_sync_package_paths {interp} { - if {![interp exists $interp]} { - error "interp_sync_package_paths error. interp '$interp' not found. Create it first with \[interp create $interp\]" - } - interp eval $interp [list set ::auto_path $::auto_path] - interp eval $interp {tcl::tm::remove {*}[tcl::tm::list]} - interp eval $interp [list tcl::tm::add {*}[lreverse [tcl::tm::list]]] - } - - proc objclone {obj} { - append obj2 $obj {} - } - proc set_clone {varname obj} { - #used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_clone varnmame $val] - append obj2 $obj {} - uplevel 1 [list set $varname $obj2] - } - - - - proc format_number {numbers_or_commaformattednumbers {delim ""} {groupsize ""}} { - variable has_twapi - if {$has_twapi} { - if {$delim eq "" && $groupsize eq ""} { - set localeid [twapi::get_system_default_lcid] - } - } - #when using twapi we currently only get the localeid - not the specific defaults - #when not using twapi, or on non-windows platforms - we don't currently have a mechanism to look up user preferences for this - set default_delim "," - set default_groupsize 3 - - set results [list] - set nums [objclone $numbers_or_commaformattednumbers] ;#stops single num from getting internal rep of list - foreach inputnum $nums { - set number [objclone $inputnum] - #also handle tcl 8.7+ underscores in numbers - set number [string map [list _ "" , ""] $number] - #normalize e.g 2e4 -> 20000.0 - set number [expr {$number}] - - if {$has_twapi} { - if {$delim eq "" && $groupsize eq ""} { - lappend results [twapi::format_number $number $localeid -idigits -1] - continue - } else { - #setting just one of delim or groupsize means we don't get the user's localeid based default for the non-set one - #todo - document it? Find a way to lookup localeid based defaults whenever either is unspecified? - if {$delim eq ""} {set delim $default_delim} - if {$groupsize eq ""} {set groupsize $default_groupsize} - lappend results [twapi::format_number $number 0 -idigits -1 -sthousand $delim -sgrouping $groupsize] - continue - } - } - #todo - get configured user defaults - if {$delim eq ""} { - set delim $default_delim - } - if {$groupsize eq ""} { - set groupsize $default_groupsize - } - - lappend results [delimit_number $number $delim $groupsize] - } - - if {[llength $results] == 1} { - #keep intrep as string rather than list - return [lindex $results 0] - } - return $results - } - - - #from wiki https://wiki.tcl-lang.org/page/Delimiting+Numberse - # Given a number represented as a string, insert delimiters to break it up for - # readability. Normally, the delimiter will be a comma which will be inserted every - # three digits. However, the delimiter and groupsize are optional arguments, - # permitting use in other locales. - # - # The string is assumed to consist of digits, possibly preceded by spaces, - # and possibly containing a decimal point, i.e.: [:space:]*[:digit:]*\.[:digit:]* - - proc delimit_number {unformattednumber {delim ","} {GroupSize 3}} { - set number [objclone $unformattednumber] - set number [string map {_ ""} $number] - #normalize using expr - e.g 2e4 -> 20000.0 - set number [expr {$number}] - # First, extract right hand part of number, up to and including decimal point - set point [string last "." $number]; - if {$point >= 0} { - set PostDecimal [string range $number $point+1 end]; - set PostDecimalP 1; - } else { - set point [expr {[string length $number] + 1}] - set PostDecimal ""; - set PostDecimalP 0; - } - - # Now extract any leading spaces. review - regex for whitespace instead of just ascii space? - set ind 0; - while {[string equal [string index $number $ind] \u0020]} { - incr ind; - } - set FirstNonSpace $ind; - set LastSpace [expr {$FirstNonSpace - 1}]; - set LeadingSpaces [string range $number 0 $LastSpace]; - - # Now extract the non-fractional part of the number, omitting leading spaces. - set MainNumber [string range $number $FirstNonSpace $point-1]; - - # Insert commas into the non-fractional part. - set Length [string length $MainNumber]; - set Phase [expr {$Length % $GroupSize}] - set PhaseMinusOne [expr {$Phase -1}]; - set DelimitedMain ""; - - #First we deal with the extra stuff. - if {$Phase > 0} { - append DelimitedMain [string range $MainNumber 0 $PhaseMinusOne]; - } - set FirstInGroup $Phase; - set LastInGroup [expr {$FirstInGroup + $GroupSize -1}]; - while {$LastInGroup < $Length} { - if {$FirstInGroup > 0} { - append DelimitedMain $delim; - } - append DelimitedMain [string range $MainNumber $FirstInGroup $LastInGroup]; - incr FirstInGroup $GroupSize - incr LastInGroup $GroupSize - } - - # Reassemble the number. - if {$PostDecimalP} { - return [format "%s%s.%s" $LeadingSpaces $DelimitedMain $PostDecimal]; - } else { - return [format "%s%s" $LeadingSpaces $DelimitedMain]; - } - } - - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::lib ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -tcl::namespace::eval punk::lib::flatgrid { - namespace export filler_count rows cols col row block - - #WARNING - requires lseq and 'lsearch -stride' - #WARNING - lsearch -stride oddity with empty strings https://core.tcl-lang.org/tcl/tktview/edebb6a4 - #todo - 8.6 fallback? - - proc filler_count {listlen numcolumns} { - #if {$numcolumns <= 0} {error "filler_count requires 1 or more numcolumns"} ;#or allow divide by zero error - #if {$listlen == 0} {return $numcolumns} ;#an option - but returning zero might make more sense - expr {($numcolumns - ($listlen % $numcolumns)) % $numcolumns} - } - proc rows {list numcolumns {blank NULL}} { - set numblanks [filler_count [llength $list] $numcolumns] - set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] - set splits [lseq 0 to [llength $padded_list] by $numcolumns] - set rows [list] - set i 1 - foreach s [lrange $splits 0 end-1] { - lappend rows [lrange $padded_list $s [lindex $splits $i]-1] - incr i - } - return $rows - } - proc cols {list numcolumns {blank NULL}} { - set cols [list] - foreach colindex [lseq 0 $numcolumns-1] { - lappend cols [lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] *] - } - return $cols - } - proc cols2 {list numcolumns {blank NULL}} { - set cols [list] - foreach colindex [lseq 0 $numcolumns-1] { - lappend cols [col2 $list $numcolumns $colindex $blank] - } - return $cols - } - proc col {list numcolumns colindex {blank NULL}} { - lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] * - } - proc col2 {list numcolumns colindex {blank NULL}} { - set numblanks [filler_count [llength $list] $numcolumns] - set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] - set splits [lseq 0 to [llength $padded_list] by $numcolumns] - set col [list] - foreach s [lrange $splits 0 end-1] { - lappend col [lindex $padded_list $s+$colindex] - } - return $col - } - proc col3 {list numcolumns colindex {blank NULL}} { - set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] - lmap s [lrange [lseq 0 to [llength $padded_list] by $numcolumns] 0 end-1] {lindex $padded_list $s+$colindex} - } - proc col4 {list numcolumns colindex {blank NULL}} { - #slow - set vars [lrepeat $numcolumns _] - lset vars $colindex v - if {$blank eq ""} { - return [lmap $vars $list {set v}] - } - set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] - lmap $vars [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] {set v} - } - - proc block {list numcolumns {blank NULL}} { - set colblocks [list] - foreach c [cols $list $numcolumns $blank] { - lappend colblocks [join $c \n] " " - } - textblock::join -- {*}$colblocks - } - proc block2 {list numcolumns {blank NULL}} { - set colblocks [list] - foreach c [cols2 $list $numcolumns $blank] { - lappend colblocks [join $c \n] " " - } - textblock::join -- {*}$colblocks - } -} - -tcl::namespace::eval punk::lib::test { - - - -} - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#todo - way to generate 'internal' docs separately? -#*** !doctools -#[section Internal] -tcl::namespace::eval punk::lib::system { - #*** !doctools - #[subsection {Namespace punk::lib::system}] - #[para] Internal functions that are not part of the API - #[list_begin definitions] - - - proc mostFactorsBelow {n} { - ##*** !doctools - #[call [fun mostFactorsBelow] [arg n]] - #[para]Find the number below $n which has the greatest number of factors - #[para]This will get slow quickly as n increases (100K = 1s+ 2024) - set most 0 - set mostcount 0 - for {set i 1} {$i < $n} {incr i} { - set fc [llength [punk::lib::factors $i]] - if {$fc > $mostcount} { - set most $i - set mostcount $fc - } - } - return [list number $most numfactors $mostcount] - } - proc factorCountBelow_punk {n} { - ##*** !doctools - #[call [fun factorCountBelow] [arg n]] - #[para]For numbers 1 to n - keep a tally of the total count of factors - #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result - #[para]and as a rudimentary performance comparison - #[para]gets slow quickly! - set tally 0 - for {set i 1} {$i <= $n} {incr i} { - incr tally [llength [punk::lib::factors $i]] - } - return $tally - } - proc factorCountBelow_numtheory {n} { - ##*** !doctools - #[call [fun factorCountBelow] [arg n]] - #[para]For numbers 1 to n - keep a tally of the total count of factors - #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result - #[para]and as a rudimentary performance comparison - #[para]gets slow quickly! (significantly slower than factorCountBelow_punk) - package require math::numtheory - set tally 0 - for {set i 1} {$i <= $n} {incr i} { - incr tally [llength [math::numtheory::factors $i]] - } - return $tally - } - - proc factors2 {x} { - ##*** !doctools - #[call [fun factors2] [arg x]] - #[para]Return a sorted list of factors of x - #[para]A similar brute-force mechanism to factors - but keeps result ordering as we go. - set smallfactors [list 1] - set j 2 - set max [expr {sqrt($x)}] - while {$j < $max} { - if {($x % $j) == 0} { - lappend smallfactors $j - lappend largefactors [expr {$x / $j}] - } - incr j - } - #handle sqrt outside loop so we don't have to sort/dedup or check list membership in main loop - if {($x % $j) == 0} { - if {$j == ($x / $j)} { - lappend smallfactors $j - } - } - return [concat $smallfactors [lreverse $largefactors] $x] - } - - - - # incomplete - report which is the innermost bracket/quote etc awaiting completion for a Tcl command - #important - used by punk::repl - proc incomplete {partial} { - #we can apparently get away without concatenating current innerpartial to previous in list - REVIEW. - if {[info complete $partial]} { - return [list] - } - set clist [split $partial ""] - #puts stderr "-->$clist<--" - set waiting [list ""] - set innerpartials [list ""] - set escaped 0 - set i 0 - foreach c $clist { - if {$c eq "\\"} { - set escaped [expr {!$escaped}] - incr i - continue - } ;# set escaped 0 at end - set p [lindex $innerpartials end] - if {$escaped == 0} { - #NOTE - curly braces as switch arm keys must be unescaped and balanced. (escapes stop byte-compilation to jumpTable for switch statements for tcl8.6/8.7 at least) - switch -- $c { - {"} { - if {![info complete ${p}]} { - lappend waiting {"} - lappend innerpartials "" - } else { - if {[lindex $waiting end] eq {"}} { - #this quote is endquote - set waiting [lrange $waiting 0 end-1] - set innerpartials [lrange $innerpartials 0 end-1] - } else { - if {![info complete ${p}$c]} { - lappend waiting {"} - lappend innerpartials "" - } else { - set p ${p}${c} - lset innerpartials end $p - } - } - } - } - {[} { - if {![info complete ${p}$c]} { - lappend waiting "\]" - lappend innerpartials "" - } else { - set p ${p}${c} - lset innerpartials end $p - } - } - "{" { - if {![info complete ${p}$c]} { - lappend waiting "\}" - lappend innerpartials "" - } else { - set p ${p}${c} - lset innerpartials end $p - } - } - "}" - - default { - set waitingfor [lindex $waiting end] - if {$c eq "$waitingfor"} { - set waiting [lrange $waiting 0 end-1] - set innerpartials [lrange $innerpartials 0 end-1] - } else { - set p ${p}${c} - lset innerpartials end $p - } - } - } - } else { - set p ${p}${c} - lset innerpartials end $p - } - set escaped 0 - incr i - } - set incomplete [list] - foreach w $waiting { - #to be treated as literals - curly braces must be unescaped here - and balanced - hence the left-curly empty arm. - switch -- $w { - {"} { - lappend incomplete $w - } - {]} { - lappend incomplete "\[" - } - "{" {} - "}" { - lappend incomplete "\{" - } - } - } - set debug 0 - if {$debug} { - foreach w $waiting p $innerpartials { - puts stderr "->awaiting:'$w' partial: $p" - } - } - return $incomplete - } - #This only works for very simple cases will get confused with for example: - # {set x "a["""} - proc incomplete_naive {partial} { - if {[info complete $partial]} { - return [list] - } - set clist [split $partial ""] - set waiting [list] - set escaped 0 - foreach c $clist { - if {$c eq "\\"} { - set escaped [expr {!$escaped}] - continue - } - if {!$escaped} { - if {$c eq {"}} { - if {[lindex $waiting end] eq {"}} { - set waiting [lrange $waiting 0 end-1] - } else { - lappend waiting {"} - } - } elseif {$c eq "\["} { - lappend waiting "\]" - } elseif {$c eq "\{"} { - lappend waiting "\}" - } else { - set waitingfor [lindex $waiting end] - if {$c eq "$waitingfor"} { - set waiting [lrange $waiting 0 end-1] - } - } - } - } - set incomplete [list] - foreach w $waiting { - if {$w eq {"}} { - lappend incomplete $w - } elseif {$w eq "\]"} { - lappend incomplete "\[" - } elseif {$w eq "\}"} { - lappend incomplete "\{" - } - } - return $incomplete - } - - #get info about punk nestindex key ie type: list,dict,undetermined - # pdict devel - 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 - } - - #??? - - } - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::lib::system ---}] -} - -tcl::namespace::eval punk::lib::debug { - proc showdict {args} {} -} - -namespace eval ::punk::args::register { - #use fully qualified so 8.6 doesn't find existing var in global namespace - lappend ::punk::args::register::NAMESPACES ::punk::lib -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::lib [tcl::namespace::eval punk::lib { - variable pkg punk::lib - variable version - set version 0.1.1 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm index 17c9918b..ad60b069 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm @@ -507,6 +507,7 @@ namespace eval punk::mix::cli { -punkcheck_eventobj "\uFFFF"\ -glob *.tm\ -podglob #modpod-*\ + -tarjarglob #tarjar-*\ ] set opts [dict merge $defaults $args] @@ -519,6 +520,7 @@ namespace eval punk::mix::cli { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set fileglob [dict get $opts -glob] set podglob [dict get $opts -podglob] + set tarjarglob [dict get $opts -tarjarglob] if {![string match "*.tm" $fileglob]} { error "build_modules_from_source_to_base -glob '$fileglob' doesn't seem to target tcl modules." } @@ -580,6 +582,10 @@ namespace eval punk::mix::cli { foreach podpath $src_pods { dict set process_modules $podpath [dict create -type pod] } + set src_tarjars [glob -nocomplain -dir $current_source_dir -type d -tail $tarjarglob] + foreach tarjarpath $src_tarjars { + dict set process_modules $tarjarpath [dict create -type tarjar] + } 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] @@ -801,8 +807,173 @@ namespace eval punk::mix::cli { } } tarjar { + #maint - overall code structure same as pod - refactor? #basename may still contain #tarjar- #to be obsoleted - update modpod to (optionally) use vfs::tar ? + if {[string match #tarjar-* $basename]} { + set basename [string range $basename 8 end] + } else { + error "build_modules_from_source_to_base, tarjar, unexpected basename $basename" ;#shouldn't be possible with default tarjarglob - review - why is tarjarglob 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\ + ] + set had_error 0 + + # -max_depth -1 for no limit + set build_installername tarjars_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/#tarjar-$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/#tarjar-$basename-$module_build_version/#tarjar-loadscript-$basename.tcl + #we don't need to modify version or name of the loadscript + #just do basic sanity check that the file exists + if {![file exists $tmfile]} { + set had_error 1 + lappend notes "tarjar_loadscript_missing" + } + } + #delete and regenerate .tm + set notes [list] + if {[catch { + file delete $buildfolder/$basename-$module_build_version.tm + } err]} { + set had_error 1 + lappend notes "tm_delete_failed" + } + #create ordinary tar file without using external executable + package require tar ;#tcllib + set tarfile $buildfolder/$basename-$module_build_version.tm ;#ordinary tar file (no compression - store) + set wd [pwd] + cd $buildfolder + puts "tar::create $tarfile #tarjar-$basename-$module_build_version" + if {[catch { + tar::create $tarfile #tarjar-$basename-$module_build_version + } errMsg]} { + set had_error 1 + puts stderr "tar::create $tarfile failed with msg\n $errMsg" + lappend notes "tar_create_failed" + } + cd $wd + + if {![file exists $tarfile]} { + set had_error 1 + lappend notes "tar_result_missing" + } + + + 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 "T" + 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 + + #JMN - review + if {!$had_error} { + $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 + if {[catch { + file copy -force $modulefile $target_module_dir + } errMsg]} { + puts stderr "FAILED to copy tarjar module $modulefile to $target_module_dir" + $event targetset_end FAILED -note "could not copy $modulefile" + } else { + puts stderr "Copied tarjar module $modulefile to $target_module_dir" + # -- --- --- --- --- --- + $event targetset_end OK -note "tarjar" + } + } else { + puts -nonewline stderr "t" + set did_skip 1 + if {$is_interesting} { + puts stderr "$modulefile [$event targetset_source_changes]" + } + $event targetset_end SKIPPED + } + } } file { @@ -829,39 +1000,40 @@ namespace eval punk::mix::cli { if {[file exists $current_source_dir/#tarjar-$basename-$magicversion]} { - #rebuild the .tm from the #tarjar + #rebuilding the .tm from the #tarjar already handled above + puts -nonewline stderr "-" - if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} { + #if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} { - } else { + #} else { - } - #REVIEW - should be in same structure/depth as $target_module_dir in _build? + #} + ##REVIEW - should be in same structure/depth as $target_module_dir in _build? - #TODO - set buildfolder $current_sourcedir/_build - file mkdir $buildfolder + ##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 + #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 + #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 + #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}#]} { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm index e899a401..3de09e5e 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -73,7 +73,7 @@ tcl::namespace::eval punk::ns { set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $ns_current *]] } else { set is_absolute [string match ::* $ns_or_glob] - set has_globchars [regexp {[*?]} $ns_or_glob] + set has_globchars [regexp {[*?]} $ns_or_glob] ;#basic globs only? if {$is_absolute} { if {!$has_globchars} { if {![nsexists $ns_or_glob]} { @@ -747,7 +747,13 @@ tcl::namespace::eval punk::ns { return $nslist } - variable usageinfo_char \U1f6c8 + #The information symbol - usually i in a circle + #punkargs " symbol \U1f6c8" ;#problematic on terminals that lie about cursor position after emitting this character + #The older \u2139 could be used - but it is sometimes a boxed i, sometimes a bold stylized i, sometimes a pre-coloured boxed i + #\u24d8 (circled latein small letter i) seems more consistent and can have our own colour applied. + #variable usageinfo_char \U1f6c8 + variable usageinfo_char \u24d8 + # command has usageinfo e.g from punk::args. todo cmdline, argp, tepam etc? proc Usageinfo_mark {{ansicodes \UFFEF}} { variable usageinfo_char @@ -760,6 +766,7 @@ tcl::namespace::eval punk::ns { } } + punk::args::define { @id -id ::punk::ns::Cmark @cmd -name punk::ns::Cmark @@ -768,7 +775,7 @@ tcl::namespace::eval punk::ns { oo " symbol \u25c6" ooc " symbol \u25c7" ooo " symbol \u25c8" - punkargs " symbol \U1f6c8" + punkargs " symbol \u24d8" ensemble " symbol \u24ba" native " symbol \u24c3" unknown " symbol \u2370" @@ -797,7 +804,7 @@ tcl::namespace::eval punk::ns { return; #should be unreachable - parse should raise usage error } } - set marks [dict create oo \u25c6 ooc \u25c7 ooo \u25c8 punkargs \U1f6c8 ensemble \u24ba native \u24c3 unknown \U2370] + set marks [dict create oo \u25c6 ooc \u25c7 ooo \u25c8 punkargs \u24d8 ensemble \u24ba native \u24c3 unknown \U2370] if {[llength $ansinames]} { return "[punk::ansi::a+ {*}$ansinames][dict get $marks $type]\x1b\[0m" } else { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm index 11cd9706..7d93d529 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm @@ -1876,7 +1876,9 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #ctrl-c if {$chunk eq "\x03"} { #::punk::repl::handler_console_control "ctrl-c_via_rawloop" - error "character 03 -> ctrl-c" + puts stderr "ctrl-c via rawloop - not signal" + ::punk::repl::handler_console_control ctrl-c via_rawloop + #error "character 03 -> ctrl-c" } if {$chunk eq "\x7f"} { @@ -1898,8 +1900,9 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #for now - exit with small delay for tidyup #ctrl-z #::punk::repl::handler_console_control "ctrl-z_via_rawloop" - if {[catch {mode line}]} { - interp eval code {mode line} + if {[catch {punk::console::mode line}]} { + #REVIEW + interp eval code {punk::console::mode line} } after 1000 {exit 43} return diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm index 2ab1fb01..5d2a2725 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -92,6 +92,9 @@ namespace eval punk::repo { } lappend maincommands {*}$ln } + #fossil output was ordered in columns, but we loaded list in row-wise, messing up the order + set maincommands [lsort $maincommands] + set allcmds [lsort $allcmds] set othercmds [punk::lib::ldiff $allcmds $maincommands] set result "@leaders -min 0\n" diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm deleted file mode 100644 index 73ea752c..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm +++ /dev/null @@ -1,3209 +0,0 @@ -#copyright 2023 Julian Marcel Noble -#license: BSD (revised 3-clause) -# -#Note shellfilter is currently only directly useful for unidirectional channels e.g stdin,stderr,stdout, or for example fifo2 where only one direction is being used. -#To generalize this to bidrectional channels would require shifting around read & write methods on transform objects in a very complicated manner. -#e.g each transform would probably be a generic transform container which holds sub-objects to which read & write are indirected. -#This is left as a future exercise...possibly it's best left as a concept for uni-directional channels anyway -# - as presumably the reads/writes from a bidirectional channel could be diverted off to unidirectional pipelines for processing with less work -# (and maybe even better speed/efficiency if the data volume is asymmetrical and there is significant processing on one direction) -# - - -tcl::namespace::eval shellfilter::log { - variable allow_adhoc_tags 1 - variable open_logs [tcl::dict::create] - variable is_enabled 0 - - proc disable {} { - variable is_enabled - set is_enabled 0 - proc ::shellfilter::log::open {tag settingsdict} {} - proc ::shellfilter::log::write {tag msg} {} - proc ::shellfilter::log::write_sync {tag msg} {} - proc ::shellfilter::log::close {tag} {} - } - - proc enable {} { - variable is_enabled - set is_enabled 1 - #'tag' is an identifier for the log source. - # each tag will use it's own thread to write to the configured log target - proc ::shellfilter::log::open {tag {settingsdict {}}} { - upvar ::shellfilter::sources sourcelist - if {![dict exists $settingsdict -tag]} { - tcl::dict::set settingsdict -tag $tag - } else { - #review - if {$tag ne [tcl::dict::get $settingsdict -tag]} { - error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[tcl::dict::get $settingsdict -tag]' omit -tag, or supply same value" - } - } - if {$tag ni $sourcelist} { - lappend sourcelist $tag - } - - #note new_worker - set worker_tid [shellthread::manager::new_worker $tag $settingsdict] - #puts stderr "shellfilter::log::open this_threadid: [thread::id] tag: $tag worker_tid: $worker_tid" - return $worker_tid - } - proc ::shellfilter::log::write {tag msg} { - upvar ::shellfilter::sources sourcelist - variable allow_adhoc_tags - if {!$allow_adhoc_tags} { - if {$tag ni $sourcelist} { - error "shellfilter::log::write tag '$tag' hasn't been initialised with a call to shellfilter::log::open $tag , and allow_adhoc_tags has been set false. use shellfilter::log::require_open false to allow adhoc tags" - } - } - shellthread::manager::write_log $tag $msg - } - #write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written - proc ::shellfilter::log::write_sync {tag msg} { - shellthread::manager::write_log $tag $msg -async 0 - } - proc ::shellfilter::log::close {tag} { - #shellthread::manager::close_worker $tag - shellthread::manager::unsubscribe [list $tag]; #workertid will be added back to free list if no tags remain subscribed - } - - } - - #review - #configure whether we can call shellfilter::log::write without having called open first - proc require_open {{is_open_required {}}} { - variable allow_adhoc_tags - if {![string length $is_open_required]} { - return $allow_adhoc_tags - } else { - set truevalues [list y yes true 1] - set falsevalues [list n no false 0] - if {[string tolower $is_open_required] in $truevalues} { - set allow_adhoc_tags 1 - } elseif {[string tolower $is_open_required] in $falsevalues} { - set allow_adhoc_tags 0 - } else { - error "shellfilter::log::require_open unrecognised value '$is_open_required' try one of $truevalues or $falsevalues" - } - } - } - if {[catch {package require shellthread}]} { - shellfilter::log::disable - } else { - shellfilter::log::enable - } - -} -namespace eval shellfilter::pipe { - #write channel for program. workerthread reads other end of fifo2 and writes data somewhere - proc open_out {tag_pipename {pipesettingsdict {}}} { - set defaultsettings {-buffering full} - set settingsdict [dict merge $defaultsettings $pipesettingsdict] - package require shellthread - #we are only using the fifo in a single direction to pipe to another thread - # - so whilst wchan and rchan could theoretically each be both read & write we're only using them for one operation each - if {![catch {package require Memchan}]} { - lassign [fifo2] wchan rchan - } else { - package require tcl::chan::fifo2 - lassign [tcl::chan::fifo2] wchan rchan - } - #default -translation for both types of fifo on windows is {auto crlf} - # -encoding is as per '[encoding system]' on the platform - e.g utf-8 (e.g windows when beta-utf8 enabled) - chan configure $wchan -buffering [dict get $settingsdict -buffering] ;# - #application end must not be binary for our filters to operate on it - - - #chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation binary ;#works reasonably.. - chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation lf - - set worker_tid [shellthread::manager::new_pipe_worker $tag_pipename $settingsdict] - #puts stderr "worker_tid: $worker_tid" - - #set_read_pipe does the thread::transfer of the rchan end. -buffering setting is maintained during thread transfer - shellthread::manager::set_pipe_read_from_client $tag_pipename $worker_tid $rchan - - set pipeinfo [list localchan $wchan remotechan $rchan workertid $worker_tid direction out] - return $pipeinfo - } - - #read channel for program. workerthread writes to other end of fifo2 from whereever it's reading (stdin, file?) - proc open_in {tag_pipename {settingsdict {} }} { - package require shellthread - package require tcl::chan::fifo2 - lassign [tcl::chan::fifo2] wchan rchan - set program_chan $rchan - set worker_chan $wchan - chan configure $worker_chan -buffering [dict get $settingsdict -buffering] - chan configure $program_chan -buffering [dict get $settingsdict -buffering] - - chan configure $program_chan -blocking 0 - chan configure $worker_chan -blocking 0 - set worker_tid [shellthread::manager::new_worker $tag_pipename $settingsdict] - - shellthread::manager::set_pipe_write_to_client $tag_pipename $worker_tid $worker_chan - - set pipeinfo [list localchan $program_chan remotechan $worker_chan workertid $worker_tid direction in] - puts stderr "|jn>pipe::open_in returning $pipeinfo" - puts stderr "program_chan: [chan conf $program_chan]" - return $pipeinfo - } - -} - - - -namespace eval shellfilter::ansi { - #maint warning - - #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 - dict set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals - #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] - - #self-contained 2 byte ansi escape sequences - review more? - set 2bytecodes_dict [dict create\ - "reset_terminal" "\033c"\ - "save_cursor_posn" "\u001b7"\ - "restore_cursor_posn" "\u001b8"\ - "cursor_up_one" "\u001bM"\ - ] - set 2bytecodes [dict values $2bytecodes_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 ""] - } - -} -namespace eval shellfilter::chan { - set testobj ::shellfilter::chan::var - if {$testobj ni [info commands $testobj]} { - - oo::class create var { - variable o_datavar - variable o_trecord - variable o_enc - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - set settingsdict [dict get $tf -settings] - set varname [dict get $settingsdict -varname] - set o_datavar $varname - if {[dict exists $tf -junction]} { - set o_is_junction [dict get $tf -junction] - } else { - set o_is_junction 1 ;# as a var is diversionary - default it to be a jucntion - } - } - method initialize {ch mode} { - return [list initialize finalize write] - } - method finalize {ch} { - my destroy - } - method watch {ch events} { - # must be present but we ignore it because we do not - # post any events - } - #method read {ch count} { - # return ? - #} - method write {ch bytes} { - set stringdata [encoding convertfrom $o_enc $bytes] - append $o_datavar $stringdata - return "" - } - method meta_is_redirection {} { - return $o_is_junction - } - method meta_buffering_supported {} { - return [list line full none] - } - } - - #todo - something similar for multiple grep specs each with own -pre & -post .. store to dict? - oo::class create tee_grep_to_var { - variable o_datavar - variable o_lastxlines - variable o_trecord - variable o_grepfor - variable o_prelines - variable o_postlines - variable o_postcountdown - variable o_enc - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [tcl::dict::get $tf -encoding] - set o_lastxlines [list] - set o_postcountdown 0 - set defaults [tcl::dict::create -pre 1 -post 1] - set settingsdict [tcl::dict::get $tf -settings] - set settings [tcl::dict::merge $defaults $settingsdict] - set o_datavar [tcl::dict::get $settings -varname] - set o_grepfor [tcl::dict::get $settings -grep] - set o_prelines [tcl::dict::get $settings -pre] - set o_postlines [tcl::dict::get $settings -post] - if {[tcl::dict::exists $tf -junction]} { - set o_is_junction [tcl::dict::get $tf -junction] - } else { - set o_is_junction 0 - } - } - method initialize {transform_handle mode} { - return [list initialize finalize write] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - #method read {transform_handle count} { - # return ? - #} - method write {transform_handle bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] - set lastx $o_lastxlines - lappend o_lastxlines $logdata - - if {$o_postcountdown > 0} { - append $o_datavar $logdata - if {[regexp $o_grepfor $logdata]} { - #another match in postlines - set o_postcountdown $o_postlines - } else { - incr o_postcountdown -1 - } - } else { - if {[regexp $o_grepfor $logdata]} { - append $o_datavar [join $lastx] - append $o_datavar $logdata - set o_postcountdown $o_postlines - } - } - - if {[llength $o_lastxlines] > $o_prelines} { - set o_lastxlines [lrange $o_lastxlines 1 end] - } - return $bytes - } - method meta_is_redirection {} { - return $o_is_junction - } - method meta_buffering_supported {} { - return [list line] - } - } - - oo::class create tee_to_var { - variable o_datavars - variable o_trecord - variable o_enc - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [tcl::dict::get $tf -encoding] - set settingsdict [tcl::dict::get $tf -settings] - set varname [tcl::dict::get $settingsdict -varname] - set o_datavars $varname - if {[tcl::dict::exists $tf -junction]} { - set o_is_junction [tcl::dict::get $tf -junction] - } else { - set o_is_junction 0 - } - } - method initialize {ch mode} { - return [list initialize finalize write flush clear] - } - method finalize {ch} { - my destroy - } - method clear {ch} { - return - } - method watch {ch events} { - # must be present but we ignore it because we do not - # post any events - } - #method read {ch count} { - # return ? - #} - method flush {ch} { - return "" - } - method write {ch bytes} { - set stringdata [tcl::encoding::convertfrom $o_enc $bytes] - foreach v $o_datavars { - append $v $stringdata - } - return $bytes - } - method meta_is_redirection {} { - return $o_is_junction - } - } - oo::class create tee_to_pipe { - variable o_logsource - variable o_localchan - variable o_enc - variable o_trecord - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [tcl::dict::get $tf -encoding] - set settingsdict [tcl::dict::get $tf -settings] - if {![dict exists $settingsdict -tag]} { - error "tee_to_pipe constructor settingsdict missing -tag" - } - set o_localchan [tcl::dict::get $settingsdict -pipechan] - set o_logsource [tcl::dict::get $settingsdict -tag] - if {[tcl::dict::exists $tf -junction]} { - set o_is_junction [tcl::dict::get $tf -junction] - } else { - set o_is_junction 0 - } - } - method initialize {transform_handle mode} { - return [list initialize read drain write flush clear finalize] - } - method finalize {transform_handle} { - ::shellfilter::log::close $o_logsource - my destroy - } - method watch {transform_handle events} { - # must be present but we ignore it because we do not - # post any events - } - method clear {transform_handle} { - return - } - method drain {transform_handle} { - return "" - } - method read {transform_handle bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] - #::shellfilter::log::write $o_logsource $logdata - puts -nonewline $o_localchan $logdata - return $bytes - } - method flush {transform_handle} { - return "" - } - method write {transform_handle bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] - #::shellfilter::log::write $o_logsource $logdata - puts -nonewline $o_localchan $logdata - return $bytes - } - #a tee is not a redirection - because data still flows along the main path - method meta_is_redirection {} { - return $o_is_junction - } - - } - oo::class create tee_to_log { - variable o_tid - variable o_logsource - variable o_trecord - variable o_enc - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [tcl::dict::get $tf -encoding] - set settingsdict [tcl::dict::get $tf -settings] - if {![tcl::dict::exists $settingsdict -tag]} { - error "tee_to_log constructor settingsdict missing -tag" - } - set o_logsource [tcl::dict::get $settingsdict -tag] - set o_tid [::shellfilter::log::open $o_logsource $settingsdict] - if {[tcl::dict::exists $tf -junction]} { - set o_is_junction [tcl::dict::get $tf -junction] - } else { - set o_is_junction 0 - } - } - method initialize {ch mode} { - return [list initialize read write finalize] - } - method finalize {ch} { - ::shellfilter::log::close $o_logsource - my destroy - } - method watch {ch events} { - # must be present but we ignore it because we do not - # post any events - } - method read {ch bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] - ::shellfilter::log::write $o_logsource $logdata - return $bytes - } - method write {ch bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] - ::shellfilter::log::write $o_logsource $logdata - return $bytes - } - method meta_is_redirection {} { - return $o_is_junction - } - } - - - oo::class create logonly { - variable o_tid - variable o_logsource - variable o_trecord - variable o_enc - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - set settingsdict [dict get $tf -settings] - if {![dict exists $settingsdict -tag]} { - error "logonly constructor settingsdict missing -tag" - } - set o_logsource [dict get $settingsdict -tag] - set o_tid [::shellfilter::log::open $o_logsource $settingsdict] - } - method initialize {transform_handle mode} { - return [list initialize finalize write] - } - method finalize {transform_handle} { - ::shellfilter::log::close $o_logsource - my destroy - } - method watch {transform_handle events} { - # must be present but we ignore it because we do not - # post any events - } - #method read {transform_handle count} { - # return ? - #} - method write {transform_handle bytes} { - set logdata [encoding convertfrom $o_enc $bytes] - if 0 { - if {"utf-16le" in [encoding names]} { - set logdata [encoding convertfrom utf-16le $bytes] - } else { - set logdata [encoding convertto utf-8 $bytes] - #set logdata [encoding convertfrom unicode $bytes] - #set logdata $bytes - } - } - #set logdata $bytes - #set logdata [string map [list \r -r- \n -n-] $logdata] - #if {[string equal [string range $logdata end-1 end] "\r\n"]} { - # set logdata [string range $logdata 0 end-2] - #} - #::shellfilter::log::write_sync $o_logsource $logdata - ::shellfilter::log::write $o_logsource $logdata - #return $bytes - return - } - method meta_is_redirection {} { - return 1 - } - } - - #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::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 - variable o_enc - variable o_is_junction - constructor {tf} { - package require punk::ansi - set o_trecord $tf - set o_enc [dict get $tf -encoding] - if {[dict exists $tf -junction]} { - set o_is_junction [dict get $tf -junction] - } else { - set o_is_junction 0 - } - } - method initialize {transform_handle mode} { - return [list initialize read write clear flush drain finalize] - } - method finalize {transform_handle} { - my destroy - } - method clear {transform_handle} { - return - } - method watch {transform_handle events} { - } - method drain {transform_handle} { - return "" - } - method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - set outstring [punk::ansi::ansistrip $instring] - return [encoding convertto $o_enc $outstring] - } - method flush {transform_handle} { - return "" - } - method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - set outstring [punk::ansi::ansistrip $instring] - return [encoding convertto $o_enc $outstring] - } - method meta_is_redirection {} { - return $o_is_junction - } - } - - #a test - oo::class create reconvert { - variable o_trecord - variable o_enc - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - } - method initialize {transform_handle mode} { - return [list initialize read write finalize] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - set outstring $instring - - return [encoding convertto $o_enc $outstring] - } - method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - set outstring $instring - - return [encoding convertto $o_enc $outstring] - } - } - oo::define reconvert { - method meta_is_redirection {} { - return 0 - } - } - - - #this isn't a particularly nice thing to do to a stream - especially if someone isn't expecting ansi codes sprinkled through it. - #It can be useful for test/debugging - #Due to chunking at random breaks - we have to check if an ansi code in the underlying stream has been split - otherwise our wrapping will break the existing ansi - # - set sixelstart_re {\x1bP([;0-9]*)q} ;#7-bit - todo 8bit - #todo kitty graphics \x1b_G... - #todo iterm graphics - - oo::class create ansiwrap { - variable o_trecord - variable o_enc - variable o_colour - variable o_do_colour - variable o_do_normal - variable o_is_junction - variable o_codestack - variable o_gx_state ;#on/off alt graphics - variable o_buffered - constructor {tf} { - package require punk::ansi - set o_trecord $tf - set o_enc [tcl::dict::get $tf -encoding] - set settingsdict [tcl::dict::get $tf -settings] - if {[tcl::dict::exists $settingsdict -colour]} { - set o_colour [tcl::dict::get $settingsdict -colour] - set o_do_colour [punk::ansi::a+ {*}$o_colour] - set o_do_normal [punk::ansi::a] - } else { - set o_colour {} - set o_do_colour "" - set o_do_normal "" - } - set o_codestack [list] - set o_gx_state [expr {off}] - set o_buffered "" ;#hold back data that potentially contains partial ansi codes - if {[tcl::dict::exists $tf -junction]} { - set o_is_junction [tcl::dict::get $tf -junction] - } else { - set o_is_junction 0 - } - } - - - #todo - track when in sixel,iterm,kitty graphics data - can be very large - method Trackcodes {chunk} { - #note - caller can use 2 resets in a single unit to temporarily reset to no sgr (override ansiwrap filter) - #e.g [a+ reset reset] (0;0m vs 0;m) - - #puts stdout "===[ansistring VIEW -lf 1 $o_buffered]" - set buf $o_buffered$chunk - set emit "" - if {[string last \x1b $buf] >= 0} { - #detect will detect ansi SGR and gron groff and other codes - if {[punk::ansi::ta::detect $buf]} { - #split_codes_single regex faster than split_codes - but more resulting parts - #'single' refers to number of escapes - but can still contain e.g multiple SGR codes (or mode set operations etc) - set parts [punk::ansi::ta::split_codes_single $buf] - #process all pt/code pairs except for trailing pt - foreach {pt code} [lrange $parts 0 end-1] { - #puts "<==[ansistring VIEW -lf 1 $pt]==>" - switch -- [llength $o_codestack] { - 0 { - append emit $o_do_colour$pt$o_do_normal - } - 1 { - if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { - append emit $o_do_colour$pt$o_do_normal - set o_codestack [list] - } else { - #append emit [lindex $o_codestack 0]$pt - append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$pt - } - } - default { - append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$pt - } - } - #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { - # append emit $o_do_colour$pt$o_do_normal - # #append emit $pt - #} else { - # append emit $pt - #} - - 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] - switch -- $leadernorm { - 7CSI - 8CSI { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set o_codestack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set o_codestack [list $code] - } elseif {[punk::ansi::codetype::is_sgr $code]} { - #todo - make caching is_sgr method - set dup_posns [lsearch -all -exact $o_codestack $code] - set o_codestack [lremove $o_codestack {*}$dup_posns] - lappend o_codestack $code - } else { - - } - } - 7GFX { - switch -- [tcl::string::index $code 2] { - "0" { - set o_gx_state on - } - "B" { - set o_gx_state off - } - } - } - default { - #other ansi codes - } - } - append emit $code - } - - - set trailing_pt [lindex $parts end] - if {[string first \x1b $trailing_pt] >= 0} { - #puts stdout "...[ansistring VIEW -lf 1 $trailing_pt]...buffered:<[ansistring VIEW $o_buffered]> '[ansistring VIEW -lf 1 $emit]'" - #may not be plaintext after all - set o_buffered $trailing_pt - #puts stdout "=-=[ansistring VIEWCODES $o_buffered]" - } else { - #puts [a+ yellow]???[ansistring VIEW "'$o_buffered'<+>'$trailing_pt'"]???[a] - switch -- [llength $o_codestack] { - 0 { - append emit $o_do_colour$trailing_pt$o_do_normal - } - 1 { - if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { - append emit $o_do_colour$trailing_pt$o_do_normal - set o_codestack [list] - } else { - #append emit [lindex $o_codestack 0]$trailing_pt - append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$trailing_pt - } - } - default { - append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$trailing_pt - } - } - #if {![llength $o_codestack] || ([llength $o_codestack] ==1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]])} { - # append emit $o_do_colour$trailing_pt$o_do_normal - #} else { - # append emit $trailing_pt - #} - #the previous o_buffered formed the data we emitted - nothing new to buffer because we emitted all parts including the trailing plaintext - set o_buffered "" - } - - - } else { - #REVIEW - this holding a buffer without emitting as we go is ugly. - # - we may do better to detect and retain the opener, then use that opener to avoid false splits within the sequence. - # - we'd then need to detect the appropriate close to restart splitting and codestacking - # - we may still need to retain and append the data to the opener (in some cases?) - which is a slight memory issue - but at least we would emit everything immediately. - - - #puts "-->esc but no detect" - #no complete ansi codes - but at least one esc is present - if {[string index $buf end] eq "\x1b" && [string first \x1b $buf] == [string length $buf]-1} { - #string index in first part of && clause to avoid some unneeded scans of whole string for this test - #we can't use 'string last' - as we need to know only esc is last char in buf - #puts ">>trailing-esc<<" - set o_buffered \x1b - set emit $o_do_colour[string range $buf 0 end-1]$o_do_normal - #set emit [string range $buf 0 end-1] - set buf "" - } else { - set emit_anyway 0 - #todo - ensure non-ansi escapes in middle of chunks don't lead to ever growing buffer - if {[punk::ansi::ta::detect_st_open $buf]} { - #no detect - but we have an ST open (privacy msg etc) - allow a larger chunk before we give up - could include newlines (and even nested codes - although not widely interpreted that way in terms) - set st_partial_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of unclosed ST code - #todo - configurable ST max - use 1k for now - if {$st_partial_len < 1001} { - append o_buffered $chunk - set emit "" - set buf "" - } else { - set emit_anyway 1 - set o_buffered "" - } - } else { - set possible_code_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of possible code - #most opening sequences are 1,2 or 3 chars - review? - set open_sequence_detected [punk::ansi::ta::detect_open $buf] - if {$possible_code_len > 10 && !$open_sequence_detected} { - set emit_anyway 1 - set o_buffered "" - } else { - #could be composite sequence with params - allow some reasonable max sequence length - #todo - configurable max sequence length - #len 40-50 quite possible for SGR sequence using coloured underlines etc, even without redundancies - # - allow some headroom for redundant codes when the caller didn't merge. - if {$possible_code_len < 101} { - append o_buffered $chunk - set buf "" - set emit "" - } else { - #allow a little more grace if we at least have an opening ansi sequence of any type.. - if {$open_sequence_detected && $possible_code_len < 151} { - append o_buffered $chunk - set buf "" - set emit "" - } else { - set emit_anyway 1 - set o_buffered "" - } - } - } - } - if {$emit_anyway} { - #assert: any time emit_anyway == 1 buf already contains all of previous o_buffered and o_buffered has been cleared. - - #looked ansi-like - but we've given enough length without detecting close.. - #treat as possible plain text with some esc or unrecognised ansi sequence - switch -- [llength $o_codestack] { - 0 { - set emit $o_do_colour$buf$o_do_normal - } - 1 { - if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { - set emit $o_do_colour$buf$o_do_normal - set o_codestack [list] - } else { - #set emit [lindex $o_codestack 0]$buf - set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf - } - } - default { - #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf - set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf - } - } - #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { - # set emit $o_do_colour$buf$o_do_normal - #} else { - # set emit $buf - #} - } - } - } - } else { - #no esc - #puts stdout [a+ yellow]...[a] - #test! - switch -- [llength $o_codestack] { - 0 { - set emit $o_do_colour$buf$o_do_normal - } - 1 { - if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { - set emit $o_do_colour$buf$o_do_normal - set o_codestack [list] - } else { - #set emit [lindex $o_codestack 0]$buf - set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf - } - } - default { - #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf - set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf - } - } - set o_buffered "" - } - return [dict create emit $emit stacksize [llength $o_codestack]] - } - method initialize {transform_handle mode} { - #clear undesirable in terminal output channels (review) - return [list initialize write flush read drain finalize] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - method clear {transform_handle} { - #In the context of stderr/stdout - we probably don't want clear to run. - #Terminals might call it in the middle of a split ansi code - resulting in broken output. - #Leave clear of it the init call - puts stdout "" - set emit [tcl::encoding::convertto $o_enc $o_buffered] - set o_buffered "" - return $emit - } - method flush {transform_handle} { - #puts stdout "" - set emit [tcl::encoding::convertto $o_enc $o_buffered] - set o_buffered "" - return $emit - return - } - method write {transform_handle bytes} { - set instring [tcl::encoding::convertfrom $o_enc $bytes] - set streaminfo [my Trackcodes $instring] - set emit [dict get $streaminfo emit] - - #review - wrapping already done in Trackcodes - #if {[dict get $streaminfo stacksize] == 0} { - # #no ansi on the stack - we can wrap - # #review - # set outstring "$o_do_colour$emit$o_do_normal" - #} else { - #} - #if {[llength $o_codestack]} { - # set outstring [punk::ansi::codetype::sgr_merge_singles $o_codestack]$emit - #} else { - # set outstring $emit - #} - - set outstring $emit - - #puts stdout "decoded >>>[ansistring VIEWCODES $outstring]<<<" - #puts stdout "re-encoded>>>[ansistring VIEW [tcl::encoding::convertto $o_enc $outstring]]<<<" - return [tcl::encoding::convertto $o_enc $outstring] - } - method Write_naive {transform_handle bytes} { - set instring [tcl::encoding::convertfrom $o_enc $bytes] - set outstring "$o_do_colour$instring$o_do_normal" - #set outstring ">>>$instring" - return [tcl::encoding::convertto $o_enc $outstring] - } - method drain {transform_handle} { - return "" - } - method read {transform_handle bytes} { - set instring [tcl::encoding::convertfrom $o_enc $bytes] - set outstring "$o_do_colour$instring$o_do_normal" - return [tcl::encoding::convertto $o_enc $outstring] - } - method meta_is_redirection {} { - return $o_is_junction - } - } - #todo - something - oo::class create rebuffer { - variable o_trecord - variable o_enc - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - } - method initialize {transform_handle mode} { - return [list initialize read write finalize] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - set outstring $instring - - return [encoding convertto $o_enc $outstring] - } - method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - #set outstring [string map [list \n ] $instring] - set outstring $instring - - return [encoding convertto $o_enc $outstring] - #return [encoding convertto utf-16le $outstring] - } - } - oo::define rebuffer { - method meta_is_redirection {} { - return 0 - } - } - - #has slight buffering/withholding of lone training cr - we can't be sure that a cr at end of chunk is part of \r\n sequence - oo::class create tounix { - variable o_trecord - variable o_enc - variable o_last_char_was_cr - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - set settingsdict [dict get $tf -settings] - if {[dict exists $tf -junction]} { - set o_is_junction [dict get $tf -junction] - } else { - set o_is_junction 0 - } - set o_last_char_was_cr 0 - } - method initialize {transform_handle mode} { - return [list initialize write finalize] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - #don't use read - method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - set outstring $instring - - return [encoding convertto $o_enc $outstring] - } - method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - #set outstring [string map [list \n ] $instring] - - if {$o_last_char_was_cr} { - set instring "\r$instring" - } - - set outstring [string map {\r\n \n} $instring] - set lastchar [string range $outstring end end] - if {$lastchar eq "\r"} { - set o_last_char_was_cr 1 - set outstring [string range $outstring 0 end-1] - } else { - set o_last_char_was_cr 0 - } - #review! can we detect eof here on the transform_handle? - #if eof, we don't want to strip a trailing \r - - return [encoding convertto $o_enc $outstring] - #return [encoding convertto utf-16le $outstring] - } - } - oo::define tounix { - method meta_is_redirection {} { - return $o_is_junction - } - } - #write to handle case where line-endings already \r\n too - oo::class create towindows { - variable o_trecord - variable o_enc - variable o_last_char_was_cr - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - set settingsdict [dict get $tf -settings] - if {[dict exists $tf -junction]} { - set o_is_junction [dict get $tf -junction] - } else { - set o_is_junction 0 - } - set o_last_char_was_cr 0 - } - method initialize {transform_handle mode} { - return [list initialize write finalize] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - #don't use read - method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - set outstring $instring - - return [encoding convertto $o_enc $outstring] - } - method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - #set outstring [string map [list \n ] $instring] - - if {$o_last_char_was_cr} { - set instring "\r$instring" - } - - set outstring [string map {\r\n \uFFFF} $instring] - set outstring [string map {\n \r\n} $outstring] - set outstring [string map {\uFFFF \r\n} $outstring] - - set lastchar [string range $outstring end end] - if {$lastchar eq "\r"} { - set o_last_char_was_cr 1 - set outstring [string range $outstring 0 end-1] - } else { - set o_last_char_was_cr 0 - } - #review! can we detect eof here on the transform_handle? - #if eof, we don't want to strip a trailing \r - - return [encoding convertto $o_enc $outstring] - #return [encoding convertto utf-16le $outstring] - } - } - oo::define towindows { - method meta_is_redirection {} { - return $o_is_junction - } - } - - } -} - -# ---------------------------------------------------------------------------- -#review float/sink metaphor. -#perhaps something with the concept of upstream and downstream? -#need concepts for push towards data, sit in middle where placed, and lag at tail of data stream. -## upstream for stdin is at the bottom of the stack and for stdout is the top of the stack. -#upstream,neutral-upstream,downstream,downstream-aside,downstream-replace (default neutral-upstream - require action 'stack' to use standard channel stacking concept and ignore other actions) -#This is is a bit different from the float/sink metaphor which refers to the channel stacking order as opposed to the data-flow direction. -#The idea would be that whether input or output -# upstream additions go to the side closest to the datasource -# downstream additions go furthest from the datasource -# - all new additions go ahead of any diversions as the most upstream diversion is the current end of the stream in a way. -# - this needs review regarding subsequent removal of the diversion and whether filters re-order in response.. -# or if downstream & neutral additions are reclassified upon insertion if they land among existing upstreams(?) -# neutral-upstream goes to the datasource side of the neutral-upstream list. -# No 'neutral' option provided so that we avoid the need to think forwards or backwards when adding stdin vs stdout shellfilter does the necessary pop/push reordering. -# No 'neutral-downstream' to reduce complexity. -# downstream-replace & downstream-aside head downstream to the first diversion they encounter. ie these actions are no longer referring to the stack direction but only the dataflow direction. -# -# ---------------------------------------------------------------------------- -# -# 'filters' are transforms that don't redirect -# - limited range of actions to reduce complexity. -# - any requirement not fulfilled by float,sink,sink-replace,sink-sideline should be done by multiple pops and pushes -# -#actions can float to top of filters or sink to bottom of filters -#when action is of type sink, it can optionally replace or sideline the first non-filter it encounters (highest redirection on the stack.. any lower are starved of the stream anyway) -# - sideline means to temporarily replace the item and keep a record, restoring if/when we are removed from the transform stack -# -##when action is of type float it can't replace or sideline anything. A float is added above any existing floats and they stay in the same order relative to each other, -#but non-floats added later will sit below all floats. -#(review - float/sink initially designed around output channels. For stdin the dataflow is reversed. implement float-aside etc?) -# -# -#action: float sink sink-replace,sink-sideline -# -# -## note - whether stack is for input or output we maintain it in the same direction - which is in sync with the tcl chan pop chan push concept. -## -namespace eval shellfilter::stack { - namespace export {[a-z]*} - namespace ensemble create - #todo - implement as oo ? - variable pipelines [list] - - proc items {} { - #review - stdin,stdout,stderr act as pre-existing pipelines, and we can't create a new one with these names - so they should probably be autoconfigured and listed.. - # - but in what contexts? only when we find them in [chan names]? - variable pipelines - return [dict keys $pipelines] - } - proc item {pipename} { - variable pipelines - return [dict get $pipelines $pipename] - } - proc item_tophandle {pipename} { - variable pipelines - set handle "" - if {[dict exists $pipelines $pipename stack]} { - set stack [dict get $pipelines $pipename stack] - set topstack [lindex $stack end] ;#last item in stack is top (for output channels anyway) review comment. input chans? - if {$topstack ne ""} { - if {[dict exists $topstack -handle]} { - set handle [dict get $topstack -handle] - } - } - } - return $handle - } - proc status {{pipename *} args} { - variable pipelines - set pipecount [dict size $pipelines] - set tabletitle "$pipecount pipelines active" - set t [textblock::class::table new $tabletitle] - $t add_column -headers [list channel-ident] - $t add_column -headers [list device-info localchan] - $t configure_column 1 -header_colspans {3} - $t add_column -headers [list "" remotechan] - $t add_column -headers [list "" tid] - $t add_column -headers [list stack-info] - foreach k [dict keys $pipelines $pipename] { - set lc [dict get $pipelines $k device localchan] - set rc [dict get $pipelines $k device remotechan] - if {[dict exists $k device workertid]} { - set tid [dict get $pipelines $k device workertid] - } else { - set tid "-" - } - set stack [dict get $pipelines $k stack] - if {![llength $stack]} { - set stackinfo "" - } else { - set tbl_inner [textblock::class::table new] - $tbl_inner configure -show_edge 0 - foreach rec $stack { - set handle [punk::lib::dict_getdef $rec -handle ""] - set id [punk::lib::dict_getdef $rec -id ""] - set transform [namespace tail [punk::lib::dict_getdef $rec -transform ""]] - set settings [punk::lib::dict_getdef $rec -settings ""] - $tbl_inner add_row [list $id $transform $handle $settings] - } - set stackinfo [$tbl_inner print] - $tbl_inner destroy - } - $t add_row [list $k $lc $rc $tid $stackinfo] - } - set result [$t print] - $t destroy - return $result - } - proc status1 {{pipename *} args} { - variable pipelines - - set pipecount [dict size $pipelines] - set tableprefix "$pipecount pipelines active\n" - foreach p [dict keys $pipelines] { - append tableprefix " " $p \n - } - package require overtype - #todo -verbose - set table "" - set ac1 [string repeat " " 15] - set ac2 [string repeat " " 42] - set ac3 [string repeat " " 70] - append table "[overtype::left $ac1 channel-ident] " - append table "[overtype::left $ac2 device-info] " - append table "[overtype::left $ac3 stack-info]" - append table \n - - - set bc1 [string repeat " " 5] ;#stack id - set bc2 [string repeat " " 25] ;#transform - set bc3 [string repeat " " 50] ;#settings - - foreach k [dict keys $pipelines $pipename] { - set lc [dict get $pipelines $k device localchan] - if {[dict exists $k device workertid]} { - set tid [dict get $pipelines $k device workertid] - } else { - set tid "" - } - - - set col1 [overtype::left $ac1 $k] - set col2 [overtype::left $ac2 "localchan: $lc tid:$tid"] - - set stack [dict get $pipelines $k stack] - if {![llength $stack]} { - set col3 $ac3 - } else { - set rec [lindex $stack 0] - set bcol1 [overtype::left $bc1 [dict get $rec -id]] - set bcol2 [overtype::left $bc2 [namespace tail [dict get $rec -transform]]] - set bcol3 [overtype::left $bc3 [dict get $rec -settings]] - set stackrow "$bcol1 $bcol2 $bcol3" - set col3 [overtype::left $ac3 $stackrow] - } - - append table "$col1 $col2 $col3\n" - - - foreach rec [lrange $stack 1 end] { - set col1 $ac1 - set col2 $ac2 - if {[llength $rec]} { - set bc1 [overtype::left $bc1 [dict get $rec -id]] - set bc2 [overtype::left $bc2 [namespace tail [dict get $rec -transform]]] - set bc3 [overtype::left $bc3 [dict get $rec -settings]] - set stackrow "$bc1 $bc2 $bc3" - set col3 [overtype::left $ac3 $stackrow] - } else { - set col3 $ac3 - } - append table "$col1 $col2 $col3\n" - } - - } - return $tableprefix$table - } - #used for output channels - we usually want to sink redirections below the floaters and down to topmost existing redir - proc _get_stack_floaters {stack} { - set floaters [list] - foreach t [lreverse $stack] { - switch -- [dict get $t -action] { - float { - lappend floaters $t - } - default { - break - } - } - } - return [lreverse $floaters] - } - - - - #for output-channel sinking - proc _get_stack_top_redirection {stack} { - set r 0 ;#reverse index - foreach t [lreverse $stack] { - set obj [dict get $t -obj] - if {[$obj meta_is_redirection]} { - set idx [expr {[llength $stack] - ($r + 1) }] ;#forward index - return [list index $idx record $t] - } - incr r - } - #not found - return [list index -1 record {}] - } - #exclude float-locked, locked, sink-locked - proc _get_stack_top_redirection_replaceable {stack} { - set r 0 ;#reverse index - foreach t [lreverse $stack] { - set action [dict get $t -action] - if {![string match "*locked*" $action]} { - set obj [dict get $t -obj] - if {[$obj meta_is_redirection]} { - set idx [expr {[llength $stack] - ($r + 1) }] ;#forward index - return [list index $idx record $t] - } - } - incr r - } - #not found - return [list index -1 record {}] - } - - - #for input-channels ? - proc _get_stack_bottom_redirection {stack} { - set i 0 - foreach t $stack { - set obj [dict get $t -obj] - if {[$obj meta_is_redirection]} { - return [linst index $i record $t] - } - incr i - } - #not found - return [list index -1 record {}] - } - - - proc get_next_counter {pipename} { - variable pipelines - #use dictn incr ? - set counter [dict get $pipelines $pipename counter] - incr counter - dict set pipelines $pipename counter $counter - return $counter - } - - proc unwind {pipename} { - variable pipelines - set stack [dict get $pipelines $pipename stack] - set localchan [dict get $pipelines $pipename device localchan] - foreach tf [lreverse $stack] { - chan pop $localchan - } - dict set pipelines $pipename [list] - } - #todo - proc delete {pipename {wait 0}} { - variable pipelines - set pipeinfo [dict get $pipelines $pipename] - set deviceinfo [dict get $pipeinfo device] - set localchan [dict get $deviceinfo localchan] - unwind $pipename - - #release associated thread - set tid [dict get $deviceinfo workertid] - if {$wait} { - thread::release -wait $tid - } else { - thread::release $tid - } - - #Memchan closes without error - tcl::chan::fifo2 raises something like 'can not find channel named "rc977"' - REVIEW. why? - catch {chan close $localchan} - } - #review - proc name clarity is questionable. remove_stackitem? - proc remove {pipename remove_id} { - variable pipelines - if {![dict exists $pipelines $pipename]} { - puts stderr "WARNING: shellfilter::stack::remove pipename '$pipename' not found in pipelines dict: '$pipelines' [info level -1]" - return - } - set stack [dict get $pipelines $pipename stack] - set localchan [dict get $pipelines $pipename device localchan] - set posn 0 - set idposn -1 - set asideposn -1 - foreach t $stack { - set id [dict get $t -id] - if {$id eq $remove_id} { - set idposn $posn - break - } - #look into asides (only can be one for now) - if {[llength [dict get $t -aside]]} { - set a [dict get $t -aside] - if {[dict get $a -id] eq $remove_id} { - set asideposn $posn - break - } - } - incr posn - } - - if {$asideposn > 0} { - #id wasn't found directly in stack, but in an -aside. we don't need to pop anything - just clear this aside record - set container [lindex $stack $asideposn] - dict set container -aside {} - lset stack $asideposn $container - dict set pipelines $pipename stack $stack - } else { - if {$idposn < 0} { - ::shellfilter::log::write shellfilter "ERROR shellfilter::stack::remove $pipename id '$remove_id' not found" - puts stderr "|WARNING>shellfilter::stack::remove $pipename id '$remove_id' not found" - return 0 - } - set removed_item [lindex $stack $idposn] - - #include idposn in poplist - set poplist [lrange $stack $idposn end] - set stack [lreplace $stack $idposn end] - #pop all chans before adding anything back in! - foreach p $poplist { - chan pop $localchan - } - - if {[llength [dict get $removed_item -aside]]} { - set restore [dict get $removed_item -aside] - set t [dict get $restore -transform] - set tsettings [dict get $restore -settings] - set obj [$t new $restore] - set h [chan push $localchan $obj] - dict set restore -handle $h - dict set restore -obj $obj - lappend stack $restore - } - - #put popped back except for the first one, which we want to remove - foreach p [lrange $poplist 1 end] { - set t [dict get $p -transform] - set tsettings [dict get $p -settings] - set obj [$t new $p] - set h [chan push $localchan $obj] - dict set p -handle $h - dict set p -obj $obj - lappend stack $p - } - dict set pipelines $pipename stack $stack - } - #JMNJMN 2025 review! - #show_pipeline $pipename -note "after_remove $remove_id" - return 1 - } - - #pop a number of items of the top of the stack, add our transform record, and add back all (or the tail of poplist if pushstartindex > 0) - proc insert_transform {pipename stack transformrecord poplist {pushstartindex 0}} { - variable pipelines - set bottom_pop_posn [expr {[llength $stack] - [llength $poplist]}] - set poplist [lrange $stack $bottom_pop_posn end] - set stack [lreplace $stack $bottom_pop_posn end] - - set localchan [dict get $pipelines $pipename device localchan] - foreach p [lreverse $poplist] { - chan pop $localchan - } - set transformname [dict get $transformrecord -transform] - set transformsettings [dict get $transformrecord -settings] - set obj [$transformname new $transformrecord] - set h [chan push $localchan $obj] - dict set transformrecord -handle $h - dict set transformrecord -obj $obj - dict set transformrecord -note "insert_transform" - lappend stack $transformrecord - foreach p [lrange $poplist $pushstartindex end] { - set t [dict get $p -transform] - set tsettings [dict get $p -settings] - set obj [$t new $p] - set h [chan push $localchan $obj] - #retain previous -id - code that added it may have kept reference and not expecting it to change - dict set p -handle $h - dict set p -obj $obj - dict set p -note "re-added" - - lappend stack $p - } - return $stack - } - - #fifo2 - proc new {pipename args} { - variable pipelines - if {($pipename in [dict keys $pipelines]) || ($pipename in [chan names])} { - error "shellfilter::stack::new error: pipename '$pipename' already exists" - } - - set opts [dict merge {-settings {}} $args] - set defaultsettings [dict create -raw 1 -buffering line -direction out] - set targetsettings [dict merge $defaultsettings [dict get $opts -settings]] - - set direction [dict get $targetsettings -direction] - - #pipename is the source/facility-name ? - if {$direction eq "out"} { - set pipeinfo [shellfilter::pipe::open_out $pipename $targetsettings] - } else { - puts stderr "|jn> pipe::open_in $pipename $targetsettings" - set pipeinfo [shellfilter::pipe::open_in $pipename $targetsettings] - } - #open_out/open_in will configure buffering based on targetsettings - - set program_chan [dict get $pipeinfo localchan] - set worker_chan [dict get $pipeinfo remotechan] - set workertid [dict get $pipeinfo workertid] - - - set deviceinfo [dict create pipename $pipename localchan $program_chan remotechan $worker_chan workertid $workertid direction $direction] - dict set pipelines $pipename [list counter 0 device $deviceinfo stack [list]] - - return $deviceinfo - } - #we 'add' rather than 'push' because transforms can float,sink and replace/sideline so they don't necessarily go to the top of the transform stack - proc add {pipename transformname args} { - variable pipelines - #chan names doesn't reflect available channels when transforms are in place - #e.g stdout may exist but show as something like file191f5b0dd80 - if {($pipename ni [dict keys $pipelines])} { - if {[catch {eof $pipename} is_eof]} { - error "shellfilter::stack::add no existing chan or pipename matching '$pipename' in channels:[chan names] or pipelines:$pipelines use stdin/stderr/stdout or shellfilter::stack::new " - } - } - set args [dict merge {-action "" -settings {}} $args] - set action [dict get $args -action] - set transformsettings [dict get $args -settings] - if {[string first "::" $transformname] < 0} { - set transformname ::shellfilter::chan::$transformname - } - if {![llength [info commands $transformname]]} { - error "shellfilter::stack::push unknown transform '$transformname'" - } - - - if {![dict exists $pipelines $pipename]} { - #pipename must be in chan names - existing device/chan - #record a -read and -write end even if the device is only being used as one or the other - set deviceinfo [dict create pipename $pipename localchan $pipename remotechan {}] - dict set pipelines $pipename [list counter 0 device $deviceinfo stack [list]] - } else { - set deviceinfo [dict get $pipelines $pipename device] - } - - set id [get_next_counter $pipename] - set stack [dict get $pipelines $pipename stack] - set localchan [dict get $deviceinfo localchan] - - #we redundantly store chan in each transform - makes debugging clearer - # -encoding similarly could be stored only at the pipeline level (or even queried directly each filter-read/write), - # but here it may help detect unexpected changes during lifetime of the stack and avoids the chance of callers incorrectly using the transform handle?) - # jn - set transform_record [list -id $id -chan $pipename -encoding [chan configure $localchan -encoding] -transform $transformname -aside {} {*}$args] - switch -glob -- $action { - float - float-locked { - set obj [$transformname new $transform_record] - set h [chan push $localchan $obj] - dict set transform_record -handle $h - dict set transform_record -obj $obj - lappend stack $transform_record - } - "" - locked { - set floaters [_get_stack_floaters $stack] - if {![llength $floaters]} { - set obj [$transformname new $transform_record] - set h [chan push $localchan $obj] - dict set transform_record -handle $h - dict set transform_record -obj $obj - lappend stack $transform_record - } else { - set poplist $floaters - set stack [insert_transform $pipename $stack $transform_record $poplist] - } - } - "sink*" { - set redirinfo [_get_stack_top_redirection $stack] - set idx_existing_redir [dict get $redirinfo index] - if {$idx_existing_redir == -1} { - #no existing redirection transform on the stack - #pop everything.. add this record as the first redirection on the stack - set poplist $stack - set stack [insert_transform $pipename $stack $transform_record $poplist] - } else { - switch -glob -- $action { - "sink-replace" { - #include that index in the poplist - set poplist [lrange $stack $idx_existing_redir end] - #pop all from idx_existing_redir to end, but put back 'lrange $poplist 1 end' - set stack [insert_transform $pipename $stack $transform_record $poplist 1] - } - "sink-aside*" { - set existing_redir_record [lindex $stack $idx_existing_redir] - if {[string match "*locked*" [dict get $existing_redir_record -action]]} { - set put_aside 0 - #we can't aside this one - sit above it instead. - set poplist [lrange $stack $idx_existing_redir+1 end] - set stack [lrange $stack 0 $idx_existing_redir] - } else { - set put_aside 1 - dict set transform_record -aside [lindex $stack $idx_existing_redir] - set poplist [lrange $stack $idx_existing_redir end] - set stack [lrange $stack 0 $idx_existing_redir-1] - } - foreach p $poplist { - chan pop $localchan - } - set transformname [dict get $transform_record -transform] - set transform_settings [dict get $transform_record -settings] - set obj [$transformname new $transform_record] - set h [chan push $localchan $obj] - dict set transform_record -handle $h - dict set transform_record -obj $obj - dict set transform_record -note "insert_transform-with-aside" - lappend stack $transform_record - #add back poplist *except* the one we transferred into -aside (if we were able) - foreach p [lrange $poplist $put_aside end] { - set t [dict get $p -transform] - set tsettings [dict get $p -settings] - set obj [$t new $p] - set h [chan push $localchan $obj] - #retain previous -id - code that added it may have kept reference and not expecting it to change - dict set p -handle $h - dict set p -obj $obj - dict set p -note "re-added-after-sink-aside" - lappend stack $p - } - } - default { - #plain "sink" - #we only sink to the topmost redirecting filter - which makes sense for an output channel - #For stdin.. this is more problematic as we're more likely to want to intercept the bottom most redirection. - #todo - review. Consider making default insert position for input channels to be at the source... and float/sink from there. - # - we don't currently know from the stack api if adding input vs output channel - so this needs work to make intuitive. - # consider splitting stack::add to stack::addinput stack::addoutput to split the different behaviour - set poplist [lrange $stack $idx_existing_redir+1 end] - set stack [insert_transform $pipename $stack $transform_record $poplist] - } - } - } - } - default { - error "shellfilter::stack::add unimplemented action '$action'" - } - } - - dict set pipelines $pipename stack $stack - #puts stdout "==" - #puts stdout "==>stack: $stack" - #puts stdout "==" - - #JMNJMN - #show_pipeline $pipename -note "after_add $transformname $args" - return $id - } - proc show_pipeline {pipename args} { - variable pipelines - set stack [dict get $pipelines $pipename stack] - set tag "SHELLFILTER::STACK" - #JMN - load from config - #::shellfilter::log::open $tag {-syslog 127.0.0.1:514} - if {[catch { - ::shellfilter::log::open $tag {-syslog ""} - } err]} { - #e.g safebase interp can't load required modules such as shellthread (or Thread) - puts stderr "shellfilter::show_pipeline cannot open log" - return - } - ::shellfilter::log::write $tag "transform stack for $pipename $args" - foreach tf $stack { - ::shellfilter::log::write $tag " $tf" - } - - } -} - - -namespace eval shellfilter { - variable sources [list] - variable stacks [dict create] - - proc ::shellfilter::redir_channel_to_log {chan args} { - variable sources - set default_logsettings [dict create \ - -tag redirected_$chan -syslog "" -file ""\ - ] - if {[dict exists $args -action]} { - set action [dict get $args -action] - } else { - # action "sink" is a somewhat reasonable default for an output redirection transform - # but it can make it harder to configure a plain ordered stack if the user is not expecting it, so we'll default to stack - # also.. for stdin transform sink makes less sense.. - #todo - default "stack" instead of empty string - set action "" - } - if {[dict exists $args -settings]} { - set logsettings [dict get $args -settings] - } else { - set logsettings {} - } - - set logsettings [dict merge $default_logsettings $logsettings] - set tag [dict get $logsettings -tag] - if {$tag ni $sources} { - lappend sources $tag - } - - set id [shellfilter::stack::add $chan logonly -action $action -settings $logsettings] - return $id - } - - proc ::shellfilter::redir_output_to_log {tagprefix args} { - variable sources - - set default_settings [list -tag ${tagprefix} -syslog "" -file ""] - - set opts [dict create -action "" -settings {}] - set opts [dict merge $opts $args] - set optsettings [dict get $opts -settings] - set settings [dict merge $default_settings $optsettings] - - set tag [dict get $settings -tag] - if {$tag ne $tagprefix} { - error "shellfilter::redir_output_to_log -tag value must match supplied tagprefix:'$tagprefix'. Omit -tag, or make it the same. It will automatically be suffixed with stderr and stdout. Use redir_channel_to_log if you want to separately configure each channel" - } - lappend sources ${tagprefix}stdout ${tagprefix}stderr - - set stdoutsettings $settings - dict set stdoutsettings -tag ${tagprefix}stdout - set stderrsettings $settings - dict set stderrsettings -tag ${tagprefix}stderr - - set idout [redir_channel_to_log stdout -action [dict get $opts -action] -settings $stdoutsettings] - set iderr [redir_channel_to_log stderr -action [dict get $opts -action] -settings $stderrsettings] - - return [list $idout $iderr] - } - - #eg try: set v [list #a b c] - #vs set v {#a b c} - proc list_is_canonical l { - #courtesy DKF via wiki https://wiki.tcl-lang.org/page/BNF+for+Tcl - if {[catch {llength $l}]} {return 0} - string equal $l [list {*}$l] - } - - #return a dict keyed on numerical list index showing info about each element - # - particularly - # 'wouldbrace' to indicate that the item would get braced by Tcl when added to another list - # 'head_tail_chars' to show current first and last character (in case it's wrapped e.g in double or single quotes or an existing set of braces) - proc list_element_info {inputlist} { - set i 0 - set info [dict create] - set testlist [list] - foreach original_item $inputlist { - #--- - # avoid sharing internal rep with original items in the list (avoids shimmering of rep in original list for certain items such as paths) - unset -nocomplain item - append item $original_item {} - #--- - - set iteminfo [dict create] - set itemlen [string length $item] - lappend testlist $item - set tcl_len [string length $testlist] - set diff [expr {$tcl_len - $itemlen}] - if {$diff == 0} { - dict set iteminfo wouldbrace 0 - dict set iteminfo wouldescape 0 - } else { - #test for escaping vs bracing! - set testlistchars [split $testlist ""] - if {([lindex $testlistchars 0] eq "\{") && ([lindex $testlistchars end] eq "\}")} { - dict set iteminfo wouldbrace 1 - dict set iteminfo wouldescape 0 - } else { - dict set iteminfo wouldbrace 0 - dict set iteminfo wouldescape 1 - } - } - set testlist [list] - set charlist [split $item ""] - set char_a [lindex $charlist 0] - set char_b [lindex $charlist 1] - set char_ab ${char_a}${char_b} - set char_y [lindex $charlist end-1] - set char_z [lindex $charlist end] - set char_yz ${char_y}${char_z} - - if { ("{" in $charlist) || ("}" in $charlist) } { - dict set iteminfo has_braces 1 - set innerchars [lrange $charlist 1 end-1] - if {("{" in $innerchars) || ("}" in $innerchars)} { - dict set iteminfo has_inner_braces 1 - } else { - dict set iteminfo has_inner_braces 0 - } - } else { - dict set iteminfo has_braces 0 - dict set iteminfo has_inner_braces 0 - } - - #todo - brace/char counting to determine if actually 'wrapped' - #e.g we could have list element {((abc)} - which appears wrapped if only looking at first and last chars. - #also {(x) (y)} as a list member.. how to treat? - if {$itemlen <= 1} { - dict set iteminfo apparentwrap "not" - } else { - #todo - switch on $char_a$char_z - if {($char_a eq {"}) && ($char_z eq {"})} { - dict set iteminfo apparentwrap "doublequotes" - } elseif {($char_a eq "'") && ($char_z eq "'")} { - dict set iteminfo apparentwrap "singlequotes" - } elseif {($char_a eq "(") && ($char_z eq ")")} { - dict set iteminfo apparentwrap "brackets" - } elseif {($char_a eq "\{") && ($char_z eq "\}")} { - dict set iteminfo apparentwrap "braces" - } elseif {($char_a eq "^") && ($char_z eq "^")} { - dict set iteminfo apparentwrap "carets" - } elseif {($char_a eq "\[") && ($char_z eq "\]")} { - dict set iteminfo apparentwrap "squarebrackets" - } elseif {($char_a eq "`") && ($char_z eq "`")} { - dict set iteminfo apparentwrap "backquotes" - } elseif {($char_a eq "\n") && ($char_z eq "\n")} { - dict set iteminfo apparentwrap "lf-newline" - } elseif {($char_ab eq "\r\n") && ($char_yz eq "\r\n")} { - dict set iteminfo apparentwrap "crlf-newline" - } else { - dict set iteminfo apparentwrap "not-determined" - } - - } - dict set iteminfo wrapbalance "unknown" ;#a hint to caller that apparentwrap is only a guide. todo - possibly make wrapbalance indicate 0 for unbalanced.. and positive numbers for outer-count of wrappings. - #e.g {((x)} == 0 {((x))} == 1 {(x) (y (z))} == 2 - dict set iteminfo head_tail_chars [list $char_a $char_z] - set namemap [list \ - \r cr\ - \n lf\ - {"} doublequote\ - {'} singlequote\ - "`" backquote\ - "^" caret\ - \t tab\ - " " sp\ - "\[" lsquare\ - "\]" rsquare\ - "(" lbracket\ - ")" rbracket\ - "\{" lbrace\ - "\}" rbrace\ - \\ backslash\ - / forwardslash\ - ] - if {[string length $char_a]} { - set char_a_name [string map $namemap $char_a] - } else { - set char_a_name "emptystring" - } - if {[string length $char_z]} { - set char_z_name [string map $namemap $char_z] - } else { - set char_z_name "emptystring" - } - - dict set iteminfo head_tail_names [list $char_a_name $char_z_name] - dict set iteminfo len $itemlen - dict set iteminfo difflen $diff ;#2 for braces, 1 for quoting?, or 0. - dict set info $i $iteminfo - incr i - } - return $info - } - - - #parse bracketed expression (e.g produced by vim "shellxquote=(" ) into a tcl (nested) list - #e.g {(^c:/my spacey/path^ >^somewhere^)} - #e.g {(blah (etc))}" - #Result is always a list - even if only one toplevel set of brackets - so it may need [lindex $result 0] if input is the usual case of {( ...)} - # - because it also supports the perhaps less likely case of: {( ...) unbraced (...)} etc - # Note that - #maintenance warning - duplication in branches for bracketed vs unbracketed! - proc parse_cmd_brackets {str} { - #wordwrappers currently best suited to non-bracket entities - no bracket matching within - anything goes until end-token reached. - # - but.. they only take effect where a word can begin. so a[x y] may be split at the space unless it's within some other wraper e.g " a[x y]" will not break at the space - # todo - consider extending the in-word handling of word_bdepth which is currently only applied to () i.e aaa(x y) is supported but aaa[x y] is not as the space breaks the word up. - set wordwrappers [list \ - "\"" [list "\"" "\"" "\""]\ - {^} [list "\"" "\"" "^"]\ - "'" [list "'" "'" "'"]\ - "\{" [list "\{" "\}" "\}"]\ - {[} [list {[} {]} {]}]\ - ] ;#dict mapping start_character to {replacehead replacetail expectedtail} - set shell_specials [list "|" "|&" "<" "<@" "<<" ">" "2>" ">&" ">>" "2>>" ">>&" ">@" "2>@" "2>@1" ">&@" "&" "&&" ] ;#words/chars that may precede an opening bracket but don't merge with the bracket to form a word. - #puts "pb:$str" - set in_bracket 0 - set in_word 0 - set word "" - set result {} - set word_bdepth 0 - set word_bstack [list] - set wordwrap "" ;#only one active at a time - set bracketed_elements [dict create] - foreach char [split $str ""] { - #puts "c:$char bracketed:$bracketed_elements" - if {$in_bracket > 0} { - if {$in_word} { - if {[string length $wordwrap]} { - #anything goes until end-char - #todo - lookahead and only treat as closing if before a space or ")" ? - lassign [dict get $wordwrappers $wordwrap] _open closing endmark - if {$char eq $endmark} { - set wordwrap "" - append word $closing - dict lappend bracketed_elements $in_bracket $word - set word "" - set in_word 0 - } else { - append word $char - } - } else { - if {$word_bdepth == 0} { - #can potentially close off a word - or start a new one if word-so-far is a shell-special - if {$word in $shell_specials} { - if {$char eq ")"} { - dict lappend bracketed_elements $in_bracket $word - set subresult [dict get $bracketed_elements $in_bracket] - dict set bracketed_elements $in_bracket [list] - incr in_bracket -1 - if {$in_bracket == 0} { - lappend result $subresult - } else { - dict lappend bracketed_elements $in_bracket $subresult - } - set word "" - set in_word 0 - } elseif {[regexp {[\s]} $char]} { - dict lappend bracketed_elements $in_bracket $word - set word "" - set in_word 0 - } elseif {$char eq "("} { - dict lappend bracketed_elements $in_bracket $word - set word "" - set in_word 0 - incr in_bracket - } else { - #at end of shell-specials is another point to look for word started by a wordwrapper char - #- expect common case of things like >^/my/path^ - if {$char in [dict keys $wordwrappers]} { - dict lappend bracketed_elements $in_bracket $word - set word "" - set in_word 1 ;#just for explicitness.. we're straight into the next word. - set wordwrap $char - set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. - } else { - #something unusual.. keep going with word! - append word $char - } - } - } else { - - if {$char eq ")"} { - dict lappend bracketed_elements $in_bracket $word - set subresult [dict get $bracketed_elements $in_bracket] - dict set bracketed_elements $in_bracket [list] - incr in_bracket -1 - if {$in_bracket == 0} { - lappend result $subresult - } else { - dict lappend bracketed_elements $in_bracket $subresult - } - set word "" - set in_word 0 - } elseif {[regexp {[\s]} $char]} { - dict lappend bracketed_elements $in_bracket $word - set word "" - set in_word 0 - } elseif {$char eq "("} { - #ordinary word up-against and opening bracket - brackets are part of word. - incr word_bdepth - append word "(" - } else { - append word $char - } - } - } else { - #currently only () are used for word_bdepth - todo add all or some wordwrappers chars so that the word_bstack can have multiple active. - switch -- $char { - "(" { - incr word_bdepth - lappend word_bstack $char - append word $char - } - ")" { - incr word_bdepth -1 - set word_bstack [lrange $word_bstack 0 end-1] - append word $char - } - default { - #spaces and chars added to word as it's still in a bracketed section - append word $char - } - } - } - } - } else { - - if {$char eq "("} { - incr in_bracket - - } elseif {$char eq ")"} { - set subresult [dict get $bracketed_elements $in_bracket] - dict set bracketed_elements $in_bracket [list] - incr in_bracket -1 - if {$in_bracket == 0} { - lappend result $subresult - } else { - dict lappend bracketed_elements $in_bracket $subresult - } - } elseif {[regexp {[\s]} $char]} { - # - } else { - #first char of word - look for word-wrappers - if {$char in [dict keys $wordwrappers]} { - set wordwrap $char - set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. - } else { - set word $char - } - set in_word 1 - } - } - } else { - if {$in_word} { - if {[string length $wordwrap]} { - lassign [dict get $wordwrappers $wordwrap] _open closing endmark - if {$char eq $endmark} { - set wordwrap "" - append word $closing - lappend result $word - set word "" - set in_word 0 - } else { - append word $char - } - } else { - - if {$word_bdepth == 0} { - if {$word in $shell_specials} { - if {[regexp {[\s]} $char]} { - lappend result $word - set word "" - set in_word 0 - } elseif {$char eq "("} { - lappend result $word - set word "" - set in_word 0 - incr in_bracket - } else { - #at end of shell-specials is another point to look for word started by a wordwrapper char - #- expect common case of things like >^/my/path^ - if {$char in [dict keys $wordwrappers]} { - lappend result $word - set word "" - set in_word 1 ;#just for explicitness.. we're straight into the next word. - set wordwrap $char - set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. - } else { - #something unusual.. keep going with word! - append word $char - } - } - - } else { - if {[regexp {[\s)]} $char]} { - lappend result $word - set word "" - set in_word 0 - } elseif {$char eq "("} { - incr word_bdepth - append word $char - } else { - append word $char - } - } - } else { - switch -- $char { - "(" { - incr word_bdepth - append word $char - } - ")" { - incr word_bdepth -1 - append word $char - } - default { - append word $char - } - } - } - } - } else { - if {[regexp {[\s]} $char]} { - #insig whitespace(?) - } elseif {$char eq "("} { - incr in_bracket - dict set bracketed_elements $in_bracket [list] - } elseif {$char eq ")"} { - error "unbalanced bracket - unable to proceed result so far: $result bracketed_elements:$bracketed_elements" - } else { - #first char of word - look for word-wrappers - if {$char in [dict keys $wordwrappers]} { - set wordwrap $char - set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. - } else { - set word $char - } - set in_word 1 - } - } - } - #puts "----$bracketed_elements" - } - if {$in_bracket > 0} { - error "shellfilter::parse_cmd_brackets missing close bracket. input was '$str'" - } - if {[dict exists $bracketed_elements 0]} { - #lappend result [lindex [dict get $bracketed_elements 0] 0] - lappend result [dict get $bracketed_elements 0] - } - if {$in_word} { - lappend result $word - } - return $result - } - - #only double quote if argument not quoted with single or double quotes - proc dquote_if_not_quoted {a} { - set wrapchars [string cat [string range $a 0 0] [string range $a end end]] - switch -- $wrapchars { - {""} - {''} { - return $a - } - default { - set newinner [string map [list {"} "\\\""] $a] - return "\"$newinner\"" - } - } - } - - #proc dquote_if_not_bracketed/braced? - - #wrap in double quotes if not double-quoted - proc dquote_if_not_dquoted {a} { - set wrapchars [string cat [string range $a 0 0] [string range $a end end]] - switch -- $wrapchars { - {""} { - return $a - } - default { - #escape any inner quotes.. - set newinner [string map [list {"} "\\\""] $a] - return "\"$newinner\"" - } - } - } - proc dquote {a} { - #escape any inner quotes.. - set newinner [string map [list {"} "\\\""] $a] - return "\"$newinner\"" - } - proc get_scriptrun_from_cmdlist_dquote_if_not {cmdlist {shellcmdflag ""}} { - set scr [auto_execok "script"] - if {[string length $scr]} { - #set scriptrun "( $c1 [lrange $cmdlist 1 end] )" - set arg1 [lindex $cmdlist 0] - if {[string first " " $arg1]>0} { - set c1 [dquote_if_not_quoted $arg1] - #set c1 "\"$arg1\"" - } else { - set c1 $arg1 - } - - if {[string length $shellcmdflag]} { - set scriptrun "$shellcmdflag \$($c1 " - } else { - set scriptrun "\$($c1 " - } - #set scriptrun "$c1 " - foreach a [lrange $cmdlist 1 end] { - #set a [string map [list "/" "//"] $a] - #set a [string map [list "\"" "\\\""] $a] - if {[string first " " $a] > 0} { - append scriptrun [dquote_if_not_quoted $a] - } else { - append scriptrun $a - } - append scriptrun " " - } - set scriptrun [string trim $scriptrun] - append scriptrun ")" - #return [list $scr -q -e -c $scriptrun /dev/null] - return [list $scr -e -c $scriptrun /dev/null] - } else { - return $cmdlist - } - } - - proc ::shellfilter::trun {commandlist args} { - #jmn - } - - - # run a command (or tcl script) with tees applied to stdout/stderr/stdin (or whatever channels are being used) - # By the point run is called - any transforms should already be in place on the channels if they're needed. - # The tees will be inline with none,some or all of those transforms depending on how the stack was configured - # (upstream,downstream configured via -float,-sink etc) - proc ::shellfilter::run {commandlist args} { - #must be a list. If it was a shell commandline string. convert it elsewhere first. - - variable sources - set runtag "shellfilter-run" - #set tid [::shellfilter::log::open $runtag [list -syslog 127.0.0.1:514]] - set tid [::shellfilter::log::open $runtag [list -syslog ""]] - if {[catch {llength $commandlist} listlen]} { - set listlen "" - } - ::shellfilter::log::write $runtag " commandlist:'$commandlist' listlen:$listlen strlen:[string length $commandlist]" - - #flush stdout - #flush stderr - - #adding filters with sink-aside will temporarily disable the existing redirection - #All stderr/stdout from the shellcommand will now tee to the underlying stderr/stdout as well as the configured syslog - - set defaults [dict create \ - -teehandle command \ - -outchan stdout \ - -errchan stderr \ - -inchan stdin \ - -tclscript 0 \ - ] - set opts [dict merge $defaults $args] - - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- - set outchan [dict get $opts -outchan] - set errchan [dict get $opts -errchan] - set inchan [dict get $opts -inchan] - set teehandle [dict get $opts -teehandle] - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- - set is_script [dict get $opts -tclscript] - dict unset opts -tclscript ;#don't pass it any further - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- - set teehandle_out ${teehandle}out ;#default commandout - set teehandle_err ${teehandle}err - set teehandle_in ${teehandle}in - - - #puts stdout "shellfilter initialising tee_to_pipe transforms for in/out/err" - - # sources should be added when stack::new called instead(?) - foreach source [list $teehandle_out $teehandle_err] { - if {$source ni $sources} { - lappend sources $source - } - } - set outdeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_out device] - set outpipechan [dict get $outdeviceinfo localchan] - set errdeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_err device] - set errpipechan [dict get $errdeviceinfo localchan] - - #set indeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_in device] - #set inpipechan [dict get $indeviceinfo localchan] - - #NOTE:These transforms are not necessarily at the top of each stack! - #The float/sink mechanism, along with whether existing transforms are diversionary decides where they sit. - set id_out [shellfilter::stack::add $outchan tee_to_pipe -action sink-aside -settings [list -tag $teehandle_out -pipechan $outpipechan]] - set id_err [shellfilter::stack::add $errchan tee_to_pipe -action sink-aside -settings [list -tag $teehandle_err -pipechan $errpipechan]] - - # need to use os level channel handle for stdin - try named pipes (or even sockets) instead of fifo2 for this - # If non os-level channel - the command can't be run with the redirection - # stderr/stdout can be run with non-os handles in the call - - # but then it does introduce issues with terminal-detection and behaviour for stdout at least - # - # input is also a tee - we never want to change the source at this point - just log/process a side-channel of it. - # - #set id_in [shellfilter::stack::add $inchan tee_to_pipe -action sink-aside -settings [list -tag commandin -pipechan $inpipechan]] - - - #set id_out [shellfilter::stack::add stdout tee_to_log -action sink-aside -settings [list -tag shellstdout -syslog 127.0.0.1:514 -file ""]] - #set id_err [shellfilter::stack::add stderr tee_to_log -action sink-aside -settings [list -tag shellstderr -syslog 127.0.0.1:514 -file "stderr.txt"]] - - #we need to catch errors - and ensure stack::remove calls occur. - #An error can be raised if the command couldn't even launch, as opposed to a non-zero exitcode and stderr output from the command itself. - # - if {!$is_script} { - set experiment 0 - if {$experiment} { - try { - set results [exec {*}$commandlist] - set exitinfo [list exitcode 0] - } trap CHILDSTATUS {results options} { - set exitcode [lindex [dict get $options -errorcode] 2] - set exitinfo [list exitcode $exitcode] - } - } else { - if {[catch { - #run process with stdout/stderr/stdin or with configured channels - #set exitinfo [shellcommand_stdout_stderr $commandlist $outchan $errchan $inpipechan {*}$opts] - set exitinfo [shellcommand_stdout_stderr $commandlist $outchan $errchan stdin {*}$opts] - #puts stderr "---->exitinfo $exitinfo" - - #subprocess result should usually have an "exitcode" key - #but for background execution we will get a "pids" key of process ids. - } errMsg]} { - set exitinfo [list error "$errMsg" source shellcommand_stdout_stderr] - } - } - } else { - if {[catch { - #script result - set exitinfo [list result [uplevel #0 [list eval $commandlist]]] - } errMsg]} { - set exitinfo [list error "$errMsg" errorCode $::errorCode errorInfo "$::errorInfo"] - } - } - - - #the previous redirections on the underlying inchan/outchan/errchan items will be restored from the -aside setting during removal - #Remove execution-time Tees from stack - shellfilter::stack::remove stdout $id_out - shellfilter::stack::remove stderr $id_err - #shellfilter::stack::remove stderr $id_in - - - #chan configure stderr -buffering line - #flush stdout - - - ::shellfilter::log::write $runtag " return '$exitinfo'" - ::shellfilter::log::close $runtag - return $exitinfo - } - proc ::shellfilter::logtidyup { {tags {}} } { - variable sources - set worker_errorlist [list] - set tidied_sources [list] - set tidytag "logtidy" - - - # opening a thread or writing to a log/syslog close to possible process exit is probably not a great idea. - # we should ensure the thread already exists early on if we really need logging here. - # - #set tid [::shellfilter::log::open $tidytag {-syslog 127.0.0.1:514}] - #::shellfilter::log::write $tidytag " logtidyuptags '$tags'" - - foreach s $sources { - if {$s eq $tidytag} { - continue - } - #puts "logtidyup source $s" - set close 1 - if {[llength $tags]} { - if {$s ni $tags} { - set close 0 - } - } - if {$close} { - lappend tidied_sources $s - shellfilter::log::close $s - lappend worker_errorlist {*}[shellthread::manager::get_and_clear_errors $s] - } - } - set remaining_sources [list] - foreach s $sources { - if {$s ni $tidied_sources} { - lappend remaining_sources $s - } - } - - #set sources [concat $remaining_sources $tidytag] - set sources $remaining_sources - - #shellfilter::stack::unwind stdout - #shellfilter::stack::unwind stderr - return [list tidied $tidied_sources errors $worker_errorlist] - } - - #package require tcl::chan::null - # e.g set errchan [tcl::chan::null] - # e.g chan push stdout [shellfilter::chan::var new ::some_var] - proc ::shellfilter::shellcommand_stdout_stderr {commandlist outchan errchan inchan args} { - set valid_flags [list \ - -timeout \ - -outprefix \ - -errprefix \ - -debug \ - -copytempfile \ - -outbuffering \ - -errbuffering \ - -inbuffering \ - -readprocesstranslation \ - -outtranslation \ - -stdinhandler \ - -outchan \ - -errchan \ - -inchan \ - -teehandle\ - ] - - set runtag shellfilter-run2 - #JMN - load from config - #set tid [::shellfilter::log::open $runtag [list -syslog "127.0.0.1:514"]] - set tid [::shellfilter::log::open $runtag [list -syslog ""]] - - if {[llength $args] % 2} { - error "Trailing arguments after any positional arguments must be in pairs of the form -argname argvalue. Valid flags are:'$valid_flags'" - } - set invalid_flags [list] - foreach {k -} $args { - switch -- $k { - -timeout - - -outprefix - - -errprefix - - -debug - - -copytempfile - - -outbuffering - - -errbuffering - - -inbuffering - - -readprocesstranslation - - -outtranslation - - -stdinhandler - - -outchan - - -errchan - - -inchan - - -teehandle { - } - default { - lappend invalid_flags $k - } - } - } - if {[llength $invalid_flags]} { - error "Unknown option(s)'$invalid_flags': must be one of '$valid_flags'" - } - #line buffering generally best for output channels.. keeps relative output order of stdout/stdin closer to source order - #there may be data where line buffering is inappropriate, so it's configurable per std channel - #reading inputs with line buffering can result in extraneous newlines as we can't detect trailing data with no newline before eof. - set defaults [dict create \ - -outchan stdout \ - -errchan stderr \ - -inchan stdin \ - -outbuffering none \ - -errbuffering none \ - -readprocesstranslation auto \ - -outtranslation lf \ - -inbuffering none \ - -timeout 900000\ - -outprefix ""\ - -errprefix ""\ - -debug 0\ - -copytempfile 0\ - -stdinhandler ""\ - ] - - - - set args [dict merge $defaults $args] - set outbuffering [dict get $args -outbuffering] - set errbuffering [dict get $args -errbuffering] - set inbuffering [dict get $args -inbuffering] - set readprocesstranslation [dict get $args -readprocesstranslation] - set outtranslation [dict get $args -outtranslation] - set timeout [dict get $args -timeout] - set outprefix [dict get $args -outprefix] - set errprefix [dict get $args -errprefix] - set debug [dict get $args -debug] - set copytempfile [dict get $args -copytempfile] - set stdinhandler [dict get $args -stdinhandler] - - set debugname "shellfilter-debug" - - if {$debug} { - set tid [::shellfilter::log::open $debugname [list -syslog "127.0.0.1:514"]] - ::shellfilter::log::write $debugname " commandlist '$commandlist'" - } - #'clock micros' good enough id for shellcommand calls unless one day they can somehow be called concurrently or sequentially within a microsecond and within the same interp. - # a simple counter would probably work too - #consider other options if an alternative to the single vwait in this function is used. - set call_id [tcl::clock::microseconds] ; - set ::shellfilter::shellcommandvars($call_id,exitcode) "" - set waitvar ::shellfilter::shellcommandvars($call_id,waitvar) - if {$debug} { - ::shellfilter::log::write $debugname " waitvar '$waitvar'" - } - lassign [chan pipe] rderr wrerr - chan configure $wrerr -blocking 0 - - set custom_stderr "" - set lastitem [lindex $commandlist end] - #todo - ensure we can handle 2> file (space after >) - - #review - reconsider the handling of redirections such that tcl-style are handled totally separately to other shell syntaxes! - # - #note 2>@1 must ocur as last word for tcl - but 2@stdout can occur elsewhere - #(2>@stdout echoes to main stdout - not into pipeline) - #To properly do pipelines it looks like we will have to split on | and call this proc multiple times and wire it up accordingly (presumably in separate threads) - - switch -- [string trim $lastitem] { - {&} { - set name [lindex $commandlist 0] - #background execution - stdout and stderr from child still comes here - but process is backgrounded - #FIX! - this is broken for paths with backslashes for example - #set pidlist [exec {*}[concat $name [lrange $commandlist 1 end]]] - set pidlist [exec {*}$commandlist] - return [list pids $pidlist] - } - {2>&1} - {2>@1} { - set custom_stderr {2>@1} ;#use the tcl style - set commandlist [lrange $commandlist 0 end-1] - } - default { - # 2> filename - # 2>> filename - # 2>@ openfileid - set redir2test [string range $lastitem 0 1] - if {$redir2test eq "2>"} { - set custom_stderr $lastitem - set commandlist [lrange $commandlist 0 end-1] - } - } - } - set lastitem [lindex $commandlist end] - - set teefile "" ;#empty string, write, append - #an ugly hack.. because redirections seem to arrive wrapped - review! - #There be dragons here.. - #Be very careful with list manipulation of the commandlist string.. backslashes cause havoc. commandlist must always be a well-formed list. generally avoid string manipulations on entire list or accidentally breaking a list element into parts if it shouldn't be.. - #The problem here - is that we can't always know what was intended on the commandline regarding quoting - - ::shellfilter::log::write $runtag "checking for redirections in $commandlist" - #sometimes we see a redirection without a following space e.g >C:/somewhere - #normalize - switch -regexp -- $lastitem\ - {^>[/[:alpha:]]+} { - set lastitem "> [string range $lastitem 1 end]" - }\ - {^>>[/[:alpha:]]+} { - set lastitem ">> [string range $lastitem 2 end]" - } - - - #for a redirection, we assume either a 2-element list at tail of form {> {some path maybe with spaces}} - #or that the tail redirection is not wrapped.. x y z > {some path maybe with spaces} - #we can't use list methods such as llenth on a member of commandlist - set wordlike_parts [regexp -inline -all {\S+} $lastitem] - - if {([llength $wordlike_parts] >= 2) && ([lindex $wordlike_parts 0] in [list ">>" ">"])} { - #wrapped redirection - but maybe not 'well' wrapped (unquoted filename) - set lastitem [string trim $lastitem] ;#we often see { > something} - - #don't use lassign or lrange on the element itself without checking first - #we can treat the commandlist as a whole as a well formed list but not neccessarily each element within. - #lassign $lastitem redir redirtarget - #set commandlist [lrange $commandlist 0 end-1] - # - set itemchars [split $lastitem ""] - set firstchar [lindex $itemchars 0] - set lastchar [lindex $itemchars end] - - #NAIVE test for double quoted only! - #consider for example {"a" x="b"} - #testing first and last is not decisive - #We need to decide what level of drilling down is even appropriate here.. - #if something was double wrapped - it was perhaps deliberate so we don't interpret it as something(?) - set head_tail_chars [list $firstchar $lastchar] - set doublequoted [expr {[llength [lsearch -all $head_tail_chars "\""]] == 2}] - if {[string equal "\{" $firstchar] && [string equal "\}" $lastchar]} { - set curlyquoted 1 - } else { - set curlyquoted 0 - } - - if {$curlyquoted} { - #these are not the tcl protection brackets but ones supplied in the argument - #it's still not valid to use list operations on a member of the commandlist - set inner [string range $lastitem 1 end-1] - #todo - fix! we still must assume there could be list-breaking data! - set innerwords [regexp -inline -all {\S+} $inner] ;#better than [split $inner] because we don't get extra empty elements for each whitespace char - set redir [lindex $innerwords 0] ;#a *potential* redir - to be tested below - set redirtarget [lrange $innerwords 1 end] ;#all the rest - } elseif {$doublequoted} { - ::shellfilter::log::write $debugname "doublequoting at tail of command '$commandlist'" - set inner [string range $lastitem 1 end-1] - set innerwords [regexp -inline -all {\S+} $inner] - set redir [lindex $innerwords 0] - set redirtarget [lrange $innerwords 1 end] - } else { - set itemwords [regexp -inline -all {\S+} $lastitem] - # e.g > c:\test becomes > {c:\test} - # but > c/mnt/c/test/temp.txt stays as > /mnt/c/test/temp.txt - set redir [lindex $itemwords 0] - set redirtarget [lrange $itemwords 1 end] - } - set commandlist [lrange $commandlist 0 end-1] - - } elseif {[lindex $commandlist end-1] in [list ">>" ">"]} { - #unwrapped redirection - #we should be able to use list operations like lindex and lrange here as the command itself is hopefully still a well formed list - set redir [lindex $commandlist end-1] - set redirtarget [lindex $commandlist end] - set commandlist [lrange $commandlist 0 end-2] - } else { - #no redirection - set redir "" - set redirtarget "" - #no change to command list - } - - - switch -- $redir { - ">>" - ">" { - set redirtarget [string trim $redirtarget "\""] - ::shellfilter::log::write $runtag " have redirection '$redir' to '$redirtarget'" - - set winfile $redirtarget ;#default assumption - switch -glob -- $redirtarget { - "/c/*" { - set winfile "c:/[string range $redirtarget 3 end]" - } - "/mnt/c/*" { - set winfile "c:/[string range $redirtarget 7 end]" - } - } - - if {[file exists [file dirname $winfile]]} { - #containing folder for target exists - if {$redir eq ">"} { - set teefile "write" - } else { - set teefile "append" - } - ::shellfilter::log::write $runtag "Directory exists '[file dirname $winfile]' operation:$teefile" - } else { - #we should be writing to a file.. but can't - ::shellfilter::log::write $runtag "cannot verify directory exists '[file dirname $winfile]'" - } - } - default { - ::shellfilter::log::write $runtag "No redir found!!" - } - } - - #often first element of command list is wrapped and cannot be run directly - #e.g {{ls -l} {> {temp.tmp}}} - #we will assume that if there is a single element which is a pathname containing a space - it is doubly wrapped. - # this may not be true - and the command may fail if it's just {c:\program files\etc} but it is the less common case and we currently have no way to detect. - #unwrap first element.. will not affect if not wrapped anyway (subject to comment above re spaces) - set commandlist [concat [lindex $commandlist 0] [lrange $commandlist 1 end]] - - #todo? - #child process environment. - # - to pass a different environment to the child - we would need to save the env array, modify as required, and then restore the env array. - - #to restore buffering states after run - set remember_in_out_err_buffering [list \ - [chan configure $inchan -buffering] \ - [chan configure $outchan -buffering] \ - [chan configure $errchan -buffering] \ - ] - - set remember_in_out_err_translation [list \ - [chan configure $inchan -translation] \ - [chan configure $outchan -translation] \ - [chan configure $errchan -translation] \ - ] - - - - - - chan configure $inchan -buffering $inbuffering -blocking 0 ;#we are setting up a readable handler for this - so non-blocking ok - chan configure $errchan -buffering $errbuffering - #chan configure $outchan -blocking 0 - chan configure $outchan -buffering $outbuffering ;#don't configure non-blocking. weird duplicate of *second* line occurs if you do. - # - - #-------------------------------------------- - #Tested on windows. Works to stop in output when buffering is none, reading from channel with -translation auto - #cmd, pwsh, tcl - #chan configure $outchan -translation lf - #chan configure $errchan -translation lf - #-------------------------------------------- - chan configure $outchan -translation $outtranslation - chan configure $errchan -translation $outtranslation - - #puts stderr "chan configure $wrerr [chan configure $wrerr]" - if {$debug} { - ::shellfilter::log::write $debugname "COMMAND [list $commandlist] strlen:[string length $commandlist] llen:[llength $commandlist]" - } - #todo - handle custom redirection of stderr to a file? - if {[string length $custom_stderr]} { - #::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist $custom_stderr] a+" - #set rdout [open |[concat $commandlist $custom_stderr] a+] - ::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist [list $custom_stderr <@$inchan]] [list RDONLY]" - set rdout [open |[concat $commandlist [list <@$inchan $custom_stderr]] [list RDONLY]] - set rderr "bogus" ;#so we don't wait for it - } else { - ::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist [list 2>@$wrerr <@$inchan]] [list RDONLY]" - #set rdout [open |[concat $commandlist [list 2>@$wrerr]] a+] - #set rdout [open |[concat $commandlist [list 2>@$wrerr]] [list RDWR]] - - # If we don't redirect stderr to our own tcl-based channel - then the transforms don't get applied. - # This is the whole reason we need these file-event loops. - # Ideally we need something like exec,open in tcl that interacts with transformed channels directly and emits as it runs, not only at termination - # - and that at least appears like a terminal to the called command. - #set rdout [open |[concat $commandlist [list 2>@stderr <@$inchan]] [list RDONLY]] - - - set rdout [open |[concat $commandlist [list 2>@$wrerr <@$inchan]] [list RDONLY]] - - chan configure $rderr -buffering $errbuffering -blocking 0 - chan configure $rderr -translation $readprocesstranslation - } - - - - set command_pids [pid $rdout] - #puts stderr "command_pids: $command_pids" - #tcl::process ensemble only available in 8.7+ - and it didn't prove useful here anyway - # the child process generally won't shut down until channels are closed. - # premature EOF on grandchild process launch seems to be due to lack of terminal emulation when redirecting stdin/stdout. - # worked around in punk/repl using 'script' command as a fake tty. - #set subprocesses [tcl::process::list] - #puts stderr "subprocesses: $subprocesses" - #if {[lindex $command_pids 0] ni $subprocesses} { - # puts stderr "pid [lindex $command_pids 0] not running $errMsg" - #} else { - # puts stderr "pid [lindex $command_pids 0] is running" - #} - - - if {$debug} { - ::shellfilter::log::write $debugname "pipeline pids: $command_pids" - } - - #jjj - - - chan configure $rdout -buffering $outbuffering -blocking 0 - chan configure $rdout -translation $readprocesstranslation - - if {![string length $custom_stderr]} { - chan event $rderr readable [list apply {{chan other wrerr outchan errchan waitfor errprefix errbuffering debug debugname pids} { - if {$errbuffering eq "line"} { - set countchunk [chan gets $chan chunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved - #errprefix only applicable to line buffered output - if {$countchunk >= 0} { - if {[chan eof $chan]} { - puts -nonewline $errchan ${errprefix}$chunk - } else { - puts $errchan "${errprefix}$chunk" - } - } - } else { - set chunk [chan read $chan] - if {[string length $chunk]} { - puts -nonewline $errchan $chunk - } - } - if {[chan eof $chan]} { - flush $errchan ;#jmn - #set subprocesses [tcl::process::list] - #puts stderr "subprocesses: $subprocesses" - #if {[lindex $pids 0] ni $subprocesses} { - # puts stderr "stderr reader: pid [lindex $pids 0] no longer running" - #} else { - # puts stderr "stderr reader: pid [lindex $pids 0] still running" - #} - chan close $chan - #catch {chan close $wrerr} - if {$other ni [chan names]} { - set $waitfor stderr - } - } - }} $rderr $rdout $wrerr $outchan $errchan $waitvar $errprefix $errbuffering $debug $debugname $command_pids] - } - - #todo - handle case where large amount of stdin coming in faster than rdout can handle - #as is - arbitrary amount of memory could be used because we aren't using a filevent for rdout being writable - # - we're just pumping it in to the non-blocking rdout buffers - # ie there is no backpressure and stdin will suck in as fast as possible. - # for most commandlines this probably isn't too big a deal.. but it could be a problem for multi-GB disk images etc - # - # - - ## Note - detecting trailing missing nl before eof is basically the same here as when reading rdout from executable - # - but there is a slight difference in that with rdout we get an extra blocked state just prior to the final read. - # Not known if that is significant - ## with inchan configured -buffering line - #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl -r cat - #warning reading input with -buffering line. Cannot detect missing trailing-newline at eof - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:0 eof:0 pend:-1 count:3 - #etc - #instate b:0 eof:1 pend:-1 count:-1 - - #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl -r cat - #warning reading input with -buffering line. Cannot detect missing trailing-newline at eof - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:0 eof:1 pend:-1 count:3 - #etc - - if 0 { - chan event $inchan readable [list apply {{chan wrchan inbuffering waitfor} { - #chan copy stdin $chan ;#doesn't work in a chan event - if {$inbuffering eq "line"} { - set countchunk [chan gets $chan chunk] - #puts $wrchan "stdinstate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" - if {$countchunk >= 0} { - if {[chan eof $chan]} { - puts -nonewline $wrchan $chunk - } else { - puts $wrchan $chunk - } - } - } else { - set chunk [chan read $chan] - if {[string length $chunk]} { - puts -nonewline $wrchan $chunk - } - } - if {[chan eof $chan]} { - puts stderr "|stdin_reader>eof [chan configure stdin]" - chan event $chan readable {} - #chan close $chan - chan close $wrchan write ;#half close - #set $waitfor "stdin" - } - }} $inchan $rdout $inbuffering $waitvar] - - if {[string length $stdinhandler]} { - chan configure stdin -buffering line -blocking 0 - chan event stdin readable $stdinhandler - } - } - - set actual_proc_out_buffering [chan configure $rdout -buffering] - set actual_outchan_buffering [chan configure $outchan -buffering] - #despite whatever is configured - we match our reading to how we need to output - set read_proc_out_buffering $actual_outchan_buffering - - - - if {[string length $teefile]} { - set logname "redir_[string map {: _} $winfile]_[tcl::clock::microseconds]" - set tid [::shellfilter::log::open $logname {-syslog 127.0.0.1:514}] - if {$teefile eq "write"} { - ::shellfilter::log::write $logname "opening '$winfile' for write" - set fd [open $winfile w] - } else { - ::shellfilter::log::write $logname "opening '$winfile' for appending" - set fd [open $winfile a] - } - #chan configure $fd -translation lf - chan configure $fd -translation $outtranslation - chan configure $fd -encoding utf-8 - - set tempvar_bytetotal [namespace current]::totalbytes[tcl::clock::microseconds] - set $tempvar_bytetotal 0 - chan event $rdout readable [list apply {{chan other wrerr outchan errchan read_proc_out_buffering waitfor outprefix call_id debug debugname writefile writefilefd copytempfile bytevar logtag} { - #review - if we write outprefix to normal stdout.. why not to redirected file? - #usefulness of outprefix is dubious - upvar $bytevar totalbytes - if {$read_proc_out_buffering eq "line"} { - #set outchunk [chan read $chan] - set countchunk [chan gets $chan outchunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved - if {$countchunk >= 0} { - if {![chan eof $chan]} { - set numbytes [expr {[string length $outchunk] + 1}] ;#we are assuming \n not \r\n - but count won't/can't be completely accurate(?) - review - puts $writefilefd $outchunk - } else { - set numbytes [string length $outchunk] - puts -nonewline $writefilefd $outchunk - } - incr totalbytes $numbytes - ::shellfilter::log::write $logtag "${outprefix} wrote $numbytes bytes to $writefile" - #puts $outchan "${outprefix} wrote $numbytes bytes to $writefile" - } - } else { - set outchunk [chan read $chan] - if {[string length $outchunk]} { - puts -nonewline $writefilefd $outchunk - set numbytes [string length $outchunk] - incr totalbytes $numbytes - ::shellfilter::log::write $logtag "${outprefix} wrote $numbytes bytes to $writefile" - } - } - if {[chan eof $chan]} { - flush $writefilefd ;#jmn - #set blocking so we can get exit code - chan configure $chan -blocking 1 - catch {::shellfilter::log::write $logtag "${outprefix} total bytes $totalbytes written to $writefile"} - #puts $outchan "${outprefix} total bytes $totalbytes written to $writefile" - catch {close $writefilefd} - if {$copytempfile} { - catch {file copy $writefile "[file rootname $writefile]_copy[file extension $writefile]"} - } - try { - chan close $chan - set ::shellfilter::shellcommandvars($call_id,exitcode) 0 - if {$debug} { - ::shellfilter::log::write $debugname "(teefile) -- child process returned no error. (exit code 0) --" - } - } trap CHILDSTATUS {result options} { - set code [lindex [dict get $options -errorcode] 2] - if {$debug} { - ::shellfilter::log::write $debugname "(teefile) CHILD PROCESS EXITED with code: $code" - } - set ::shellfilter::shellcommandvars($call_id,exitcode) $code - } - catch {chan close $wrerr} - if {$other ni [chan names]} { - set $waitfor stdout - } - } - }} $rdout $rderr $wrerr $outchan $errchan $read_proc_out_buffering $waitvar $outprefix $call_id $debug $debugname $winfile $fd $copytempfile $tempvar_bytetotal $logname] - - } else { - - # This occurs when we have outbuffering set to 'line' - as the 'input' from rdout which comes from the executable is also configured to 'line' - # where b:0|1 is whether chan blocked $chan returns 0 or 1 - # pend is the result of chan pending $chan - # eof is the resot of chan eof $chan - - - ##------------------------- - ##If we still read with gets,to retrieve line by line for output to line-buffered output - but the input channel is configured with -buffering none - ## then we can detect the difference - # there is an extra blocking read - but we can stil use eof with data to detect the absent newline and avoid passing an extra one on. - #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl /c cat - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:0 eof:0 pend:-1 count:3 - #etc - #instate b:0 eof:1 pend:-1 count:-1 - - #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl /u/c cat - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:1 eof:0 pend:-1 count:-1 - #instate b:0 eof:1 pend:-1 count:3 - #etc - ##------------------------ - - - #this should only occur if upstream is coming from stdin reader that has line buffering and hasn't handled the difference properly.. - ###reading with gets from line buffered input with trailing newline - #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl /c cat - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:0 eof:0 pend:-1 count:3 - #etc - #instate b:0 eof:1 pend:-1 count:-1 - - ###reading with gets from line buffered input with trailing newline - ##No detectable difference! - #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl /c cat - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:0 eof:0 pend:-1 count:3 - #etc - #instate b:0 eof:1 pend:-1 count:-1 - ##------------------------- - - #Note that reading from -buffering none and writing straight out gives no problem because we pass the newlines through as is - - - #set ::shellfilter::chan::lastreadblocked_nodata_noeof($rdout) 0 ;#a very specific case of readblocked prior to eof.. possibly not important - #this detection is disabled for now - but left for debugging in case it means something.. or changes - chan event $rdout readable [list apply {{chan other wrerr outchan errchan read_proc_out_buffering waitfor outprefix call_id debug debugname pids} { - #set outchunk [chan read $chan] - - if {$read_proc_out_buffering eq "line"} { - set countchunk [chan gets $chan outchunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved - #countchunk can be -1 before eof e.g when blocked - #debugging output inline with data - don't leave enabled - #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" - if {$countchunk >= 0} { - if {![chan eof $chan]} { - puts $outchan ${outprefix}$outchunk - } else { - puts -nonewline $outchan ${outprefix}$outchunk - #if {$::shellfilter::chan::lastreadblocked_nodata_noeof($chan)} { - # seems to be the usual case - #} else { - # #false alarm, or ? we've reached eof with data but didn't get an empty blocking read just prior - # #Not known if this occurs - # #debugging output inline with data - don't leave enabled - # puts $outchan "!!!prev read didn't block: instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" - #} - } - #set ::shellfilter::chan::lastreadblocked_nodata_noeof($chan) 0 - } else { - #set ::shellfilter::chan::lastreadblocked_nodata_noeof($chan) [expr {[chan blocked $chan] && ![chan eof $chan]}] - } - } else { - #puts $outchan "read CHANNEL $chan [chan configure $chan]" - #puts $outchan "write CHANNEL $outchan b:[chan configure $outchan -buffering] t:[chan configure $outchan -translation] e:[chan configure $outchan -encoding]" - set outchunk [chan read $chan] - #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:[string length $outchunk]" - if {[string length $outchunk]} { - #set stringrep [encoding convertfrom utf-8 $outchunk] - #set newbytes [encoding convertto utf-16 $stringrep] - #puts -nonewline $outchan $newbytes - puts -nonewline $outchan $outchunk - } - } - - if {[chan eof $chan]} { - flush $outchan ;#jmn - #for now just look for first element in the pid list.. - #set subprocesses [tcl::process::list] - #puts stderr "subprocesses: $subprocesses" - #if {[lindex $pids 0] ni $subprocesses} { - # puts stderr "stdout reader pid: [lindex $pids 0] no longer running" - #} else { - # puts stderr "stdout reader pid: [lindex $pids 0] still running" - #} - - #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan]" - chan configure $chan -blocking 1 ;#so we can get exit code - try { - chan close $chan - set ::shellfilter::shellcommandvars($call_id,exitcode) 0 - if {$debug} { - ::shellfilter::log::write $debugname " -- child process returned no error. (exit code 0) --" - } - } trap CHILDSTATUS {result options} { - set code [lindex [dict get $options -errorcode] 2] - set ::shellfilter::shellcommandvars($call_id,exitcode) $code - if {$debug} { - ::shellfilter::log::write $debugname " CHILD PROCESS EXITED with code: $code" - } - } trap CHILDKILLED {result options} { - #set code [lindex [dict get $options -errorcode] 2] - #set ::shellfilter::shellcommandvars(%id%,exitcode) $code - set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled" - if {$debug} { - ::shellfilter::log::write $debugname " CHILD PROCESS EXITED with result:'$result' options:'$options'" - } - - } finally { - #puts stdout "HERE" - #flush stdout - - } - catch {chan close $wrerr} - if {$other ni [chan names]} { - set $waitfor stdout - } - - } - }} $rdout $rderr $wrerr $outchan $errchan $read_proc_out_buffering $waitvar $outprefix $call_id $debug $debugname $command_pids] - } - - #todo - add ability to detect activity/data-flow and change timeout to only apply for period with zero data - #e.g x hrs with no data(?) - #reset timeout when data detected. - after $timeout [string map [list %w% $waitvar %id% $call_id %wrerr% $wrerr %rdout% $rdout %rderr% $rderr %debug% $debug %debugname% $debugname] { - if {[info exists ::shellfilter::shellcommandvars(%id%,exitcode)]} { - if {[set ::shellfilter::shellcommandvars(%id%,exitcode)] ne ""} { - catch { chan close %wrerr% } - catch { chan close %rdout%} - catch { chan close %rderr%} - } else { - chan configure %rdout% -blocking 1 - try { - chan close %rdout% - set ::shellfilter::shellcommandvars(%id%,exitcode) 0 - if {%debug%} { - ::shellfilter::log::write %debugname% "(timeout) -- child process returned no error. (exit code 0) --" - } - } trap CHILDSTATUS {result options} { - set code [lindex [dict get $options -errorcode] 2] - if {%debug%} { - ::shellfilter::log::write %debugname% "(timeout) CHILD PROCESS EXITED with code: $code" - } - set ::shellfilter::shellcommandvars(%id%,exitcode) $code - } trap CHILDKILLED {result options} { - set code [lindex [dict get $options -errorcode] 2] - #set code [dict get $options -code] - #set ::shellfilter::shellcommandvars(%id%,exitcode) $code - #set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled-timeout" - set ::shellfilter::shellcommandvars(%id%,exitcode) "childkilled-timeout" - if {%debug%} { - ::shellfilter::log::write %debugname% "(timeout) CHILDKILLED with code: $code" - ::shellfilter::log::write %debugname% "(timeout) result:$result options:$options" - } - - } - catch { chan close %wrerr% } - catch { chan close %rderr%} - } - set %w% "timeout" - } - }] - - - vwait $waitvar - - set exitcode [set ::shellfilter::shellcommandvars($call_id,exitcode)] - if {![string is digit -strict $exitcode]} { - puts stderr "Process exited with non-numeric code: $exitcode" - flush stderr - } - if {[string length $teefile]} { - #cannot be called from within an event handler above.. vwait reentrancy etc - catch {::shellfilter::log::close $logname} - } - - if {$debug} { - ::shellfilter::log::write $debugname " closed by: [set $waitvar] with exitcode: $exitcode" - catch {::shellfilter::log::close $debugname} - } - array unset ::shellfilter::shellcommandvars $call_id,* - - - #restore buffering to pre shellfilter::run state - lassign $remember_in_out_err_buffering bin bout berr - chan configure $inchan -buffering $bin - chan configure $outchan -buffering $bout - chan configure $errchan -buffering $berr - - lassign $remember_in_out_err_translation tin tout terr - chan configure $inchan -translation $tin - chan configure $outchan -translation $tout - chan configure $errchan -translation $terr - - - #in channel probably closed..(? review - should it be?) - catch { - chan configure $inchan -buffering $bin - } - - - return [list exitcode $exitcode] - } - -} - -package provide shellfilter [namespace eval shellfilter { - variable version - set version 0.1.9 -}] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellrun-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellrun-0.1.1.tm index 8f03892d..478c70fa 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellrun-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellrun-0.1.1.tm @@ -222,6 +222,9 @@ namespace eval shellrun { } set resolved_cmdname [auto_execok $cmdname] + if {$resolved_cmdname eq ""} { + error "Cannot find path for executable '$cmdname'" + } set repl_runid [punk::get_repl_runid] #set ::punk::last_run_display [list] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/uuid-1.0.7.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/uuid-1.0.7.tm deleted file mode 100644 index fbd43f3d..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/uuid-1.0.7.tm +++ /dev/null @@ -1,245 +0,0 @@ -# uuid.tcl - Copyright (C) 2004 Pat Thoyts -# -# UUIDs are 128 bit values that attempt to be unique in time and space. -# -# Reference: -# http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt -# -# uuid: scheme: -# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html -# -# Usage: uuid::uuid generate -# uuid::uuid equal $idA $idB - -package require Tcl 8.5 - -namespace eval uuid { - variable accel - array set accel {critcl 0} - - namespace export uuid - - variable uid - if {![info exists uid]} { - set uid 1 - } - - proc K {a b} {set a} -} - -### -# Optimization -# Caches machine info after the first pass -### - -proc ::uuid::generate_tcl_machinfo {} { - variable machinfo - if {[info exists machinfo]} { - return $machinfo - } - lappend machinfo [clock seconds]; # timestamp - lappend machinfo [clock clicks]; # system incrementing counter - lappend machinfo [info hostname]; # spatial unique id (poor) - lappend machinfo [pid]; # additional entropy - lappend machinfo [array get ::tcl_platform] - - ### - # If we have /dev/urandom just stream 128 bits from that - ### - if {[file exists /dev/urandom]} { - set fin [open /dev/urandom r] - binary scan [read $fin 128] H* machinfo - close $fin - } elseif {[catch {package require nettool}]} { - # More spatial information -- better than hostname. - # bug 1150714: opening a server socket may raise a warning messagebox - # with WinXP firewall, using ipconfig will return all IP addresses - # including ipv6 ones if available. ipconfig is OK on win98+ - if {[string equal $::tcl_platform(platform) "windows"]} { - catch {exec ipconfig} config - lappend machinfo $config - } else { - catch { - set s [socket -server void -myaddr [info hostname] 0] - K [fconfigure $s -sockname] [close $s] - } r - lappend machinfo $r - } - - if {[package provide Tk] != {}} { - lappend machinfo [winfo pointerxy .] - lappend machinfo [winfo id .] - } - } else { - ### - # If the nettool package works on this platform - # use the stream of hardware ids from it - ### - lappend machinfo {*}[::nettool::hwid_list] - } - return $machinfo -} - -# Generates a binary UUID as per the draft spec. We generate a pseudo-random -# type uuid (type 4). See section 3.4 -# -proc ::uuid::generate_tcl {} { - package require md5 2 - variable uid - - set tok [md5::MD5Init] - md5::MD5Update $tok [incr uid]; # package incrementing counter - foreach string [generate_tcl_machinfo] { - md5::MD5Update $tok $string - } - set r [md5::MD5Final $tok] - binary scan $r c* r - - # 3.4: set uuid versioning fields - lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}] - lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}] - - return [binary format c* $r] -} - -if {[string equal $tcl_platform(platform) "windows"] - && [package provide critcl] != {}} { - namespace eval uuid { - critcl::ccode { - #define WIN32_LEAN_AND_MEAN - #define STRICT - #include - #include - typedef long (__stdcall *LPFNUUIDCREATE)(UUID *); - typedef const unsigned char cu_char; - } - critcl::cproc generate_c {Tcl_Interp* interp} ok { - HRESULT hr = S_OK; - int r = TCL_OK; - UUID uuid = {0}; - HMODULE hLib; - LPFNUUIDCREATE lpfnUuidCreate = NULL; - hLib = LoadLibraryA(("rpcrt4.dll")); - if (hLib) - lpfnUuidCreate = (LPFNUUIDCREATE) - GetProcAddress(hLib, "UuidCreate"); - if (lpfnUuidCreate) { - Tcl_Obj *obj; - lpfnUuidCreate(&uuid); - obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid)); - Tcl_SetObjResult(interp, obj); - } else { - Tcl_SetResult(interp, "error: failed to create a guid", - TCL_STATIC); - r = TCL_ERROR; - } - return r; - } - } -} - -# Convert a binary uuid into its string representation. -# -proc ::uuid::tostring {uuid} { - binary scan $uuid H* s - foreach {a b} {0 7 8 11 12 15 16 19 20 end} { - append r [string range $s $a $b] - - } - return [string tolower [string trimright $r -]] -} - -# Convert a string representation of a uuid into its binary format. -# -proc ::uuid::fromstring {uuid} { - return [binary format H* [string map {- {}} $uuid]] -} - -# Compare two uuids for equality. -# -proc ::uuid::equal {left right} { - set l [fromstring $left] - set r [fromstring $right] - return [string equal $l $r] -} - -# Call our generate uuid implementation -proc ::uuid::generate {} { - variable accel - if {$accel(critcl)} { - return [generate_c] - } else { - return [generate_tcl] - } -} - -# uuid generate -> string rep of a new uuid -# uuid equal uuid1 uuid2 -# -proc uuid::uuid {cmd args} { - switch -exact -- $cmd { - generate { - if {[llength $args] != 0} { - return -code error "wrong # args:\ - should be \"uuid generate\"" - } - return [tostring [generate]] - } - equal { - if {[llength $args] != 2} { - return -code error "wrong \# args:\ - should be \"uuid equal uuid1 uuid2\"" - } - return [eval [linsert $args 0 equal]] - } - default { - return -code error "bad option \"$cmd\":\ - must be generate or equal" - } - } -} - -# ------------------------------------------------------------------------- - -# LoadAccelerator -- -# -# This package can make use of a number of compiled extensions to -# accelerate the digest computation. This procedure manages the -# use of these extensions within the package. During normal usage -# this should not be called, but the test package manipulates the -# list of enabled accelerators. -# -proc ::uuid::LoadAccelerator {name} { - variable accel - set r 0 - switch -exact -- $name { - critcl { - if {![catch {package require tcllibc}]} { - set r [expr {[info commands ::uuid::generate_c] != {}}] - } - } - default { - return -code error "invalid accelerator package:\ - must be one of [join [array names accel] {, }]" - } - } - set accel($name) $r -} - -# ------------------------------------------------------------------------- - -# Try and load a compiled extension to help. -namespace eval ::uuid { - variable e {} - foreach e {critcl} { - if {[LoadAccelerator $e]} break - } - unset e -} - -package provide uuid 1.0.7 - -# ------------------------------------------------------------------------- -# Local variables: -# mode: tcl -# indent-tabs-mode: nil -# End: diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/uuid-1.0.8.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/uuid-1.0.8.tm deleted file mode 100644 index c5cffa67..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/uuid-1.0.8.tm +++ /dev/null @@ -1,246 +0,0 @@ -# uuid.tcl - Copyright (C) 2004 Pat Thoyts -# -# UUIDs are 128 bit values that attempt to be unique in time and space. -# -# Reference: -# http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt -# -# uuid: scheme: -# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html -# -# Usage: uuid::uuid generate -# uuid::uuid equal $idA $idB - -package require Tcl 8.5 9 - -namespace eval uuid { - variable accel - array set accel {critcl 0} - - namespace export uuid - - variable uid - if {![info exists uid]} { - set uid 1 - } - - proc K {a b} {set a} -} - -### -# Optimization -# Caches machine info after the first pass -### - -proc ::uuid::generate_tcl_machinfo {} { - variable machinfo - if {[info exists machinfo]} { - return $machinfo - } - lappend machinfo [clock seconds]; # timestamp - lappend machinfo [clock clicks]; # system incrementing counter - lappend machinfo [info hostname]; # spatial unique id (poor) - lappend machinfo [pid]; # additional entropy - lappend machinfo [array get ::tcl_platform] - - ### - # If we have /dev/urandom just stream 128 bits from that - ### - if {[file exists /dev/urandom]} { - set fin [open /dev/urandom r] - fconfigure $fin -encoding binary - binary scan [read $fin 128] H* machinfo - close $fin - } elseif {[catch {package require nettool}]} { - # More spatial information -- better than hostname. - # bug 1150714: opening a server socket may raise a warning messagebox - # with WinXP firewall, using ipconfig will return all IP addresses - # including ipv6 ones if available. ipconfig is OK on win98+ - if {[string equal $::tcl_platform(platform) "windows"]} { - catch {exec ipconfig} config - lappend machinfo $config - } else { - catch { - set s [socket -server void -myaddr [info hostname] 0] - K [fconfigure $s -sockname] [close $s] - } r - lappend machinfo $r - } - - if {[package provide Tk] != {}} { - lappend machinfo [winfo pointerxy .] - lappend machinfo [winfo id .] - } - } else { - ### - # If the nettool package works on this platform - # use the stream of hardware ids from it - ### - lappend machinfo {*}[::nettool::hwid_list] - } - return $machinfo -} - -# Generates a binary UUID as per the draft spec. We generate a pseudo-random -# type uuid (type 4). See section 3.4 -# -proc ::uuid::generate_tcl {} { - package require md5 2 - variable uid - - set tok [md5::MD5Init] - md5::MD5Update $tok [incr uid]; # package incrementing counter - foreach string [generate_tcl_machinfo] { - md5::MD5Update $tok $string - } - set r [md5::MD5Final $tok] - binary scan $r c* r - - # 3.4: set uuid versioning fields - lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}] - lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}] - - return [binary format c* $r] -} - -if {[string equal $tcl_platform(platform) "windows"] - && [package provide critcl] != {}} { - namespace eval uuid { - critcl::ccode { - #define WIN32_LEAN_AND_MEAN - #define STRICT - #include - #include - typedef long (__stdcall *LPFNUUIDCREATE)(UUID *); - typedef const unsigned char cu_char; - } - critcl::cproc generate_c {Tcl_Interp* interp} ok { - HRESULT hr = S_OK; - int r = TCL_OK; - UUID uuid = {0}; - HMODULE hLib; - LPFNUUIDCREATE lpfnUuidCreate = NULL; - hLib = LoadLibraryA(("rpcrt4.dll")); - if (hLib) - lpfnUuidCreate = (LPFNUUIDCREATE) - GetProcAddress(hLib, "UuidCreate"); - if (lpfnUuidCreate) { - Tcl_Obj *obj; - lpfnUuidCreate(&uuid); - obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid)); - Tcl_SetObjResult(interp, obj); - } else { - Tcl_SetResult(interp, "error: failed to create a guid", - TCL_STATIC); - r = TCL_ERROR; - } - return r; - } - } -} - -# Convert a binary uuid into its string representation. -# -proc ::uuid::tostring {uuid} { - binary scan $uuid H* s - foreach {a b} {0 7 8 11 12 15 16 19 20 end} { - append r [string range $s $a $b] - - } - return [string tolower [string trimright $r -]] -} - -# Convert a string representation of a uuid into its binary format. -# -proc ::uuid::fromstring {uuid} { - return [binary format H* [string map {- {}} $uuid]] -} - -# Compare two uuids for equality. -# -proc ::uuid::equal {left right} { - set l [fromstring $left] - set r [fromstring $right] - return [string equal $l $r] -} - -# Call our generate uuid implementation -proc ::uuid::generate {} { - variable accel - if {$accel(critcl)} { - return [generate_c] - } else { - return [generate_tcl] - } -} - -# uuid generate -> string rep of a new uuid -# uuid equal uuid1 uuid2 -# -proc uuid::uuid {cmd args} { - switch -exact -- $cmd { - generate { - if {[llength $args] != 0} { - return -code error "wrong # args:\ - should be \"uuid generate\"" - } - return [tostring [generate]] - } - equal { - if {[llength $args] != 2} { - return -code error "wrong \# args:\ - should be \"uuid equal uuid1 uuid2\"" - } - return [eval [linsert $args 0 equal]] - } - default { - return -code error "bad option \"$cmd\":\ - must be generate or equal" - } - } -} - -# ------------------------------------------------------------------------- - -# LoadAccelerator -- -# -# This package can make use of a number of compiled extensions to -# accelerate the digest computation. This procedure manages the -# use of these extensions within the package. During normal usage -# this should not be called, but the test package manipulates the -# list of enabled accelerators. -# -proc ::uuid::LoadAccelerator {name} { - variable accel - set r 0 - switch -exact -- $name { - critcl { - if {![catch {package require tcllibc}]} { - set r [expr {[info commands ::uuid::generate_c] != {}}] - } - } - default { - return -code error "invalid accelerator package:\ - must be one of [join [array names accel] {, }]" - } - } - set accel($name) $r -} - -# ------------------------------------------------------------------------- - -# Try and load a compiled extension to help. -namespace eval ::uuid { - variable e {} - foreach e {critcl} { - if {[LoadAccelerator $e]} break - } - unset e -} - -package provide uuid 1.0.8 - -# ------------------------------------------------------------------------- -# Local variables: -# mode: tcl -# indent-tabs-mode: nil -# End: diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl b/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl index c1d3f906..858c0d2d 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl @@ -1263,6 +1263,8 @@ proc ::punkboot::punkboot_gethelp {args} { append h " - show the name and base folder of the project to be built" \n \n append h " $scriptname check" \n append h " - show module/library paths and any potentially problematic packages for running this script" \n + append h " $scriptname shell" \n + append h " - run the punk shell using bootsupport libraries." \n append h "" \n if {[llength [dict get $pkg_availability missing]] || [llength [dict get $pkg_availability broken]]} { set has_recommended 0 @@ -1331,8 +1333,9 @@ punk::args::define { subcommand -type "literal(shell)" arg -type any -optional 1 -multiple 1 } + #set argd [punk::args::parse $scriptargs -form 0 withid punkmake] -##lassign [dict values $argd] leaders opts values received +###lassign [dict values $argd] leaders opts values received # #puts stdout [punk::args::usage -scheme nocolour punkmake] #exit 1 diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/dictn-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/dictn-0.1.1.tm deleted file mode 100644 index c9ef87f2..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/dictn-0.1.1.tm +++ /dev/null @@ -1,349 +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) 2023 -# -# @@ Meta Begin -# Application dictn 0.1.1 -# Meta platform tcl -# Meta license -# @@ Meta End - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -##e.g package require frobz - - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval dictn { - namespace export {[a-z]*} - namespace ensemble create -} - - -## ::dictn::append -#This can of course 'ruin' a nested dict if applied to the wrong element -# - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl: -# %set list {a b {c d}} -# %append list x -# a b {c d}x -# IOW - don't do that unless you really know that's what you want. -# -proc ::dictn::append {dictvar path {value {}}} { - if {[llength $path] == 1} { - uplevel 1 [list dict append $dictvar $path $value] - } else { - upvar 1 $dictvar dvar - - ::set str [dict get $dvar {*}$path] - append str $val - dict set dvar {*}$path $str - } -} - -proc ::dictn::create {args} { - ::set data {} - foreach {path val} $args { - dict set data {*}$path $val - } - return $data -} - -proc ::dictn::exists {dictval path} { - return [dict exists $dictval {*}$path] -} - -proc ::dictn::filter {dictval path filterType args} { - ::set sub [dict get $dictval {*}$path] - dict filter $sub $filterType {*}$args -} - -proc ::dictn::for {keyvalvars dictval path body} { - ::set sub [dict get $dictval {*}$path] - dict for $keyvalvars $sub $body -} - -proc ::dictn::get {dictval {path {}}} { - return [dict get $dictval {*}$path] -} - -proc ::dictn::getdef {dictval path default} { - return [dict getdef $dictval {*}$path $default] -} - -proc ::dictn::getwithdefault {dictval path default} { - return [dict getdef $dictval {*}$path $default] -} - -if {[info commands ::tcl::dict::getdef] ne ""} { - proc ::dictn::incr {dictvar path {increment {}} } { - if {$increment eq ""} { - ::set increment 1 - } - if {[llength $path] == 1} { - uplevel 1 [list dict incr $dictvar $path $increment] - } else { - upvar 1 $dictvar dvar - if {![::info exists dvar]} { - dict set dvar {*}$path $increment - } else { - ::set newval [expr {[dict getdef $dvar {*}$path 0] + $increment}] - dict set dvar {*}$path $newval - } - return $dvar - } - } -} else { - proc ::dictn::incr {dictvar path {increment {}} } { - if {$increment eq ""} { - ::set increment 1 - } - if {[llength $path] == 1} { - uplevel 1 [list dict incr $dictvar $path $increment] - } else { - upvar 1 $dictvar dvar - if {![::info exists dvar]} { - dict set dvar {*}$path $increment - } else { - if {![dict exists $dvar {*}$path]} { - ::set val 0 - } else { - ::set val [dict get $dvar {*}$path] - } - ::set newval [expr {$val + $increment}] - dict set dvar {*}$path $newval - } - return $dvar - } - } -} - -proc ::dictn::info {dictval {path {}}} { - if {![string length $path]} { - return [dict info $dictval] - } else { - ::set sub [dict get $dictval {*}$path] - return [dict info $sub] - } -} - -proc ::dictn::keys {dictval {path {}} {glob {}}} { - ::set sub [dict get $dictval {*}$path] - if {[string length $glob]} { - return [dict keys $sub $glob] - } else { - return [dict keys $sub] - } -} - -proc ::dictn::lappend {dictvar path args} { - if {[llength $path] == 1} { - uplevel 1 [list dict lappend $dictvar $path {*}$args] - } else { - upvar 1 $dictvar dvar - - ::set list [dict get $dvar {*}$path] - ::lappend list {*}$args - dict set dvar {*}$path $list - } -} - -proc ::dictn::merge {args} { - error "nested merge not yet supported" -} - -#dictn remove dictionaryValue ?path ...? -proc ::dictn::remove {dictval args} { - ::set basic [list] ;#buffer basic (1element path) removals to do in a single call. - - foreach path $args { - if {[llength $path] == 1} { - ::lappend basic $path - } else { - #extract,modify,replace - ::set subpath [lrange $path 0 end-1] - - ::set sub [dict get $dictval {*}$subpath] - ::set sub [dict remove $sub [lindex $path end]] - - dict set dictval {*}$subpath $sub - } - } - - if {[llength $basic]} { - return [dict remove $dictval {*}$basic] - } else { - return $dictval - } -} - - -proc ::dictn::replace {dictval args} { - ::set basic [list] ;#buffer basic (1element path) replacements to do in a single call. - - foreach {path val} $args { - if {[llength $path] == 1} { - ::lappend basic $path $val - } else { - #extract,modify,replace - ::set subpath [lrange $path 0 end-1] - - ::set sub [dict get $dictval {*}$subpath] - ::set sub [dict replace $sub [lindex $path end] $val] - - dict set dictval {*}$subpath $sub - } - } - - - if {[llength $basic]} { - return [dict replace $dictval {*}$basic] - } else { - return $dictval - } -} - - -proc ::dictn::set {dictvar path newval} { - upvar 1 $dictvar dvar - return [dict set dvar {*}$path $newval] -} - -proc ::dictn::size {dictval {path {}}} { - return [dict size [dict get $dictval {*}$path]] -} - -proc ::dictn::unset {dictvar path} { - upvar 1 $dictvar dvar - return [dict unset dvar {*}$path -} - -proc ::dictn::update {dictvar args} { - ::set body [lindex $args end] - ::set maplist [lrange $args 0 end-1] - - upvar 1 $dictvar dvar - foreach {path var} $maplist { - if {[dict exists $dvar {*}$path]} { - uplevel 1 [list set $var [dict get $dvar $path]] - } - } - - catch {uplevel 1 $body} result - - foreach {path var} $maplist { - if {[dict exists $dvar {*}$path]} { - upvar 1 $var $var - if {![::info exists $var]} { - uplevel 1 [list dict unset $dictvar {*}$path] - } else { - uplevel 1 [list dict set $dictvar {*}$path [::set $var]] - } - } - } - return $result -} - -#an experiment. -proc ::dictn::Applyupdate {dictvar args} { - ::set body [lindex $args end] - ::set maplist [lrange $args 0 end-1] - - upvar 1 $dictvar dvar - - ::set headscript "" - ::set i 0 - foreach {path var} $maplist { - if {[dict exists $dvar {*}$path]} { - #uplevel 1 [list set $var [dict get $dvar $path]] - ::lappend arglist $var - ::lappend vallist [dict get $dvar {*}$path] - ::append headscript [string map [list %i% $i %v% $var] {upvar 1 %v% %v%; set %v% [lindex $args %i%]} ] - ::append headscript \n - ::incr i - } - } - - ::set body $headscript\r\n$body - - puts stderr "BODY: $body" - - #set result [apply [list args $body] {*}$vallist] - catch {apply [list args $body] {*}$vallist} result - - foreach {path var} $maplist { - if {[dict exists $dvar {*}$path] && [::info exists $var]} { - dict set dvar {*}$path [::set $var] - } - } - return $result -} - -proc ::dictn::values {dictval {path {}} {glob {}}} { - ::set sub [dict get $dictval {*}$path] - if {[string length $glob]} { - return [dict values $sub $glob] - } else { - return [dict values $sub] - } -} - -# Standard form: -#'dictn with dictVariable path body' -# -# Extended form: -#'dictn with dictVariable path arrayVariable body' -# -proc ::dictn::with {dictvar path args} { - if {[llength $args] == 1} { - ::set body [lindex $args 0] - return [uplevel 1 [list dict with $dictvar {*}$path $body]] - } else { - upvar 1 $dictvar dvar - ::lassign $args arrayname body - - upvar 1 $arrayname arr - array set arr [dict get $dvar {*}$path] - ::set prevkeys [array names arr] - - catch {uplevel 1 $body} result - - - foreach k $prevkeys { - if {![::info exists arr($k)]} { - dict unset $dvar {*}$path $k - } - } - foreach k [array names arr] { - dict set $dvar {*}$path $k $arr($k) - } - - return $result - } -} - - - - - - - - - - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide dictn [namespace eval dictn { - variable version - ::set version 0.1.1 -}] -return \ No newline at end of file diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/fauxlink-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/fauxlink-0.1.0.tm deleted file mode 100644 index fe16b71a..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/fauxlink-0.1.0.tm +++ /dev/null @@ -1,567 +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) 2024 -# -# @@ Meta Begin -# Application fauxlink 0.1.0 -# Meta platform tcl -# Meta license MIT -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin fauxlink_module_fauxlink 0 0.1.0] -#[copyright "2024"] -#[titledesc {faux link application shortcuts}] [comment {-- Name section and table of contents description --}] -#[moddesc {fauxlink .fxlnk}] [comment {-- Description at end of page heading --}] -#[require fauxlink] -#[keywords symlink faux fake shortcut toml] -#[description] -#[para] A cross platform shortcut/symlink alternative. -#[para] Unapologetically ugly - but practical in certain circumstances. -#[para] A solution is required for application-driven filesystem links that survives cross platform moves as well as -#[para] archiving and packaging systems. -#[para] The target is specified in a minimally-encoded form in the filename itself - but still human readable. -#[para] format of name #.fxlnk -#[para] where can be empty - then the effective nominal name is the tail of the -#[para] The + symbol substitutes for forward-slashes. -#[para] Other chars can be encoded using url-like encoding - (but only up to %7E !) -#[para] We deliberately treat higher % sequences literally. -#[para] This means actual uri::urn encoded unicode sequences (e.g %E2%99%A5 [lb]heart[rb]) can remain literal for linking to urls. -#[para] e.g if an actual + or # is required in a filename or path segment they can be encoded as %2B & %23 -#[para] e.g a link to a file file#A.txt in parent dir could be: -#[para] file%23A.txt#..+file%23A.txt.fxlnk -#[para] or equivalently (but obviously affecting sorting) #..+file%23A.txt.fxlnk -#[para] The can be unrelated to the actual target -#[para] e.g datafile.dat#..+file%23A.txt.fxlnk -#[para] This system has no filesystem support - and must be completely application driven. -#[para] This can be useful for example in application test packages which may be tarred or zipped and moved cross platform. -#[para] The target being fully specified in the name means the file doesn't have to be read for the target to be determined -#[para] Extensions to behaviour should be added in the file as text data in Toml format, -#[para] with custom data being under a single application-chosen table name -#[para] The toplevel Toml table [fauxlink] is reserved for core extensions to this system. -#[para] Aside from the 2 used for delimiting (+ #) -#[para] certain characters which might normally be allowed in filesystems are required to be encoded -#[para] e.g space and tab are required to be %20 %09 -#[para] Others that require encoding are: * ? \ / | : ; " < > -#[para] The nul character in raw form, when detected, is always mapped away to the empty string - as very few filesystems support it. -#[para] Control characters and other punctuation is optional to encode. -#[para] Generally utf-8 should be used where possible and unicode characters can often be left unencoded on modern systems. -#[para] Where encoding of unicode is desired in the nominalname,encodedtarget,tag or comment portions it can be specified as %UXXXXXXXX -#[para] There must be between 1 and 8 X digits following the %U. Interpretation of chars following %U stops at the first non-hex character. -#[para] This means %Utest would not get any translation as there were no hex digits so it would come out as %Utest -# -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#https://learn.microsoft.com/en-us/troubleshoot/windows-client/networking/url-encoding-unc-paths-not-url-decoded -# ie "//server/c/Program files" works but "//server/c/Program%20Files" is now treated by windows as a literal path with %20 in it. -#Using fauxlink - a link would be: -# "my-program-files#++server+c+Program%20Files.fxlnk" -#If we needed the old-style literal %20 it would become -# "my-program-files#++server+c+Program%2520Files.fxlnk" -# -# The file:// scheme on windows supposedly *does* decode %xx (for use in a browser) -# e.g -# pfiles#file%3a++++localhost+c+Program%2520files -# The browser will work with literal spaces too though - so it could just as well be: -# pfiles#file%3a++++localhost+c+Program%20files -#windows may default to using explorer.exe instead of a browser for file:// urls though -#and explorer doesn't want the literal %20. It probably depends what API the file:// url is to be passed to? -#in a .url shortcut either literal space or %20 will work ie %xx values are decoded - - - -#*** !doctools -#[section Overview] -#[para] overview of fauxlink -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by fauxlink -#[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 -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval fauxlink::class { - #*** !doctools - #[subsection {Namespace fauxlink::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 fauxlink { - namespace export {[a-z]*}; # Convention: export all lowercase - - #todo - enforce utf-8 - - #literal unicode chars supported by modern filesystems - leave as is - REVIEW - - - variable encode_map - variable decode_map - #most filesystems don't allow NULL - map to empty string - - #Make sure % is not in encode_map - set encode_map [dict create\ - \x00 ""\ - { } %20\ - \t %09\ - + %2B\ - # %23\ - * %2A\ - ? %3F\ - \\ %5C\ - / %2F\ - | %7C\ - : %3A\ - {;} %3B\ - {"} %22\ - < %3C\ - > %3E\ - ] - #above have some overlap with ctrl codes below. - #no big deal as it's a dict - - #must_encode - # + # * ? \ / | : ; " < > \t - # also NUL to empty string - - # also ctrl chars 01 to 1F (1..31) - for {set i 1} {$i < 32} {incr i} { - set ch [format %c $i] - set enc "%[format %02X $i]" - set enc_lower [string tolower $enc] - dict set encode_map $ch $enc - dict set decode_map $enc $ch - dict set decode_map $enc_lower $ch - } - - variable must_encode - set must_encode [dict keys $encode_map] - - - #if they are in - - #decode map doesn't include - # %00 (nul) - # %2F "/" - # %2f "/" - # %7f (del) - #we exlude the forward slash because we already have + for that - and multiple ways to specify it obscure intention. - # - set decode_map [dict merge $decode_map [dict create\ - %09 \t\ - %20 { }\ - %21 "!"\ - %22 {"}\ - %23 "#"\ - %24 "$"\ - %25 "%"\ - %26 "&"\ - %27 "'"\ - %28 "("\ - %29 ")"\ - %2A "*"\ - %2a "*"\ - %2B "+"\ - %2b "+"\ - %2C ","\ - %2c ","\ - %2D "-"\ - %2d "-"\ - %2E "."\ - %2e "."\ - %3A ":"\ - %3a ":"\ - %3B {;}\ - %3b {;}\ - %3D "="\ - %3C "<"\ - %3c "<"\ - %3d "="\ - %3E ">"\ - %3e ">"\ - %3F "?"\ - %3f "?"\ - %40 "@"\ - %5B "\["\ - %5b "\["\ - %5C "\\"\ - %5c "\\"\ - %5D "\]"\ - %5d "\]"\ - %5E "^"\ - %5e "^"\ - %60 "`"\ - %7B "{"\ - %7b "{"\ - %7C "|"\ - %7c "|"\ - %7D "}"\ - %7d "}"\ - %7E "~"\ - %7e "~"\ - ]] - #Don't go above 7f - #if we want to specify p - - - #*** !doctools - #[subsection {Namespace fauxlink}] - #[para] Core API functions for fauxlink - #[list_begin definitions] - proc Segment_mustencode_check {str} { - variable decode_map - variable encode_map ;#must_encode - set idx 0 - set err "" - foreach ch [split $str ""] { - if {[dict exists $encode_map $ch]} { - set enc [dict get $encode_map $ch] - if {[dict exists $decode_map $enc]} { - append err " char $idx should be encoded as $enc" \n - } else { - append err " no %xx encoding available. Use %UXX if really required" \n - } - } - incr idx - } - return $err ;#empty string if ok - } - - proc resolve {link} { - variable decode_map - variable encode_map - variable must_encode - set ftail [file tail $link] - set extension_name [string range [file extension $ftail] 1 end] - if {$extension_name ni [list fxlnk fauxlink]} { - set is_fauxlink 0 - #we'll process anyway - but return the result wrapped - #This should allow deliberate erroring for the calling dict user if the extension difference is inadvertent - #(e.g blindly processing all files in a folder that is normally only .fxlnk files - but then something added that happens - # to have # characters in it) - #It also means if someone really wants to use the fauxlink semantics on a different file type - # - they can - but just have to access the results differently and take that (minor) risk. - #error "fauxlink::resolve refusing to process link $link - file extension must be .fxlnk or .fauxlink" - set err_extra "\nnonstandard extension '$extension_name' for fauxlink. Check that the call to fauxlink::resolve was deliberate" - } else { - set is_fauxlink 1 - set err_extra "" - } - set linkspec [file rootname $ftail] - # - any # or + within the target path or name should have been uri encoded as %23 and %2b - if {[tcl::string::first # $linkspec] < 0} { - set err "fauxlink::resolve '$link'. Link must contain a # (usually at start if name matches target)" - append err $err_extra - error $err - } - #The 1st 2 parts of split on # are name and target file/dir - #If there are only 3 parts the 3rd part is a comment and there are no 'tags' - #if there are 4 parts - the 3rd part is a tagset where each tag begins with @ - #and each subsequent part is a comment. Empty comments are stripped from the comments list - #A tagset can be empty - but if it's not empty it must contain at least one @ and must start with @ - #e.g name.txt#path#@tag1@tag2#test###.fxlnk - #has a name, a target, 2 tags and one comment - - #check namespec already has required chars encoded - set segments [split $linkspec #] - lassign $segments namespec targetspec - #puts stderr "-->namespec $namespec" - set nametest [tcl::string::map $encode_map $namespec] - #puts stderr "-->nametest $nametest" - #nothing should be changed - if there are unencoded chars that must be encoded it is an error - if {[tcl::string::length $nametest] ne [tcl::string::length $namespec]} { - set err "fauxlink::resolve '$link' invalid chars in name part (section prior to first #)" - append err [Segment_mustencode_check $namespec] - append err $err_extra - error $err - } - #see comments below regarding 2 rounds and ordering. - set name [decode_unicode_escapes $namespec] - set name [tcl::string::map $decode_map $name] - #puts stderr "-->name: $name" - - set targetsegment [split $targetspec +] - #check each + delimited part of targetspec already has required chars encoded - set pp 0 ;#pathpart index - set targetpath_parts [list] - foreach pathpart $targetsegment { - set targettest [tcl::string::map $encode_map $pathpart] - if {[tcl::string::length $targettest] ne [tcl::string::length $pathpart]} { - set err "fauxlink::resolve '$link' invalid chars in targetpath (section following first #)" - append err [Segment_mustencode_check $pathpart] - append err $err_extra - error $err - } - #2 rounds of substitution is possibly asking for trouble.. - #We allow anything in the resultant segments anyway (as %UXXXX... allows all) - #so it's not so much about what can be encoded, - # - but it makes it harder to reason about for users - # In particular - if we map %XX first it makes %25 -> % substitution tricky - # if the user requires a literal %UXXX - they can't do %25UXXX - # the double sub would make it %UXXX -> somechar anyway. - #we do unicode first - as a 2nd round of %XX substitutions is unlikely to interfere. - #There is still the opportunity to use things like %U00000025 followed by hex-chars - # and get some minor surprises, but using %U on ascii is unlikely to be done accidentally - REVIEW - set pathpart [decode_unicode_escapes $pathpart] - set pathpart [tcl::string::map $decode_map $pathpart] - lappend targetpath_parts $pathpart - - incr pp - } - set targetpath [join $targetpath_parts /] - if {$name eq ""} { - set name [lindex $targetpath_parts end] - } - #we do the same encoding checks on tags and comments to increase chances of portability - set tags [list] - set comments [list] - switch -- [llength $segments] { - 2 { - #no tags or comments - } - 3 { - #only 3 sections - last is comment - even if looks like tags - #to make the 3rd part a tagset, an extra # would be needed - set comments [list [lindex $segments 2]] - } - default { - set tagset [lindex $segments 2] - if {$tagset eq ""} { - #ok - no tags - } else { - if {[string first @ $tagset] != 0} { - set err "fauxlink::resolve '$link' invalid tagset in 3rd #-delimited segment" - append err \n " - must begin with @" - append err $err_extra - error $err - } else { - set tagset [string range $tagset 1 end] - set rawtags [split $tagset @] - set tags [list] - foreach t $rawtags { - if {$t eq ""} { - lappend tags "" - } else { - set tagtest [tcl::string::map $encode_map $t] - if {[tcl::string::length $tagtest] ne [tcl::string::length $t]} { - set err "fauxlink::resolve '$link' invalid chars in tag [llength $tags]" - append err [Segment_mustencode_check $t] - append err $err_extra - error $err - } - lappend tags [tcl::string::map $decode_map [decode_unicode_escapes $t]] - } - } - } - } - set rawcomments [lrange $segments 3 end] - #set comments [lsearch -all -inline -not $comments ""] - set comments [list] - foreach c $rawcomments { - if {$c eq ""} {continue} - set commenttest [tcl::string::map $encode_map $c] - if {[tcl::string::length $commenttest] ne [tcl::string::length $c]} { - set err "fauxlink::resolve '$link' invalid chars in comment [llength $comments]" - append err [Segment_mustencode_check $c] - append err $err_extra - error $err - } - lappend comments [tcl::string::map $decode_map [decode_unicode_escapes $c]] - } - } - } - - set data [dict create name $name targetpath $targetpath tags $tags comments $comments fauxlinkextension $extension_name] - if {$is_fauxlink} { - #standard .fxlnk or .fauxlink - return $data - } else { - #custom extension - or called in error on wrong type of file but happened to parse. - #see comments at top regarding is_fauxlink - #make sure no keys in common at top level. - return [dict create\ - linktype $extension_name\ - note "nonstandard extension returning nonstandard dict with result in data key"\ - data $data\ - ] - } - } - variable map - - #default exclusion of / (%U2f and equivs) - #this would allow obfuscation of intention - when we have + for that anyway - proc decode_unicode_escapes {str {exclusions {/ \n \r \x00}}} { - variable map - set ucstart [string first %U $str 0] - if {$ucstart < 0} { - return $str - } - set max 8 - set map [list] - set strend [expr {[string length $str]-1}] - while {$ucstart >= 0} { - set s $ucstart - set i [expr {$s +2}] ;#skip the %U - set hex "" - while {[tcl::string::length $hex] < 8 && $i <= $strend} { - set in [string index $str $i] - if {[tcl::string::is xdigit -strict $in]} { - append hex $in - } else { - break - } - incr i - } - if {$hex ne ""} { - incr i -1 - lappend map $s $i $hex - } - set ucstart [tcl::string::first %U $str $i] - } - set out "" - set lastidx -1 - set e 0 - foreach {s e hex} $map { - append out [string range $str $lastidx+1 $s-1] - set sub [format %c 0x$hex] - if {$sub in $exclusions} { - append out %U$hex ;#put it back - } else { - append out $sub - } - set lastidx $e - } - if {$e < [tcl::string::length $str]-1} { - append out [string range $str $e+1 end] - } - return $out - } - proc link_as {name target} { - - } - - #proc sample1 {p1 args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [opt {?option value...?}]] - # #[para]Description of sample1 - # return "ok" - #} - - - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace fauxlink ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval fauxlink::lib { - namespace export {[a-z]*}; # Convention: export all lowercase - namespace path [namespace parent] - #*** !doctools - #[subsection {Namespace fauxlink::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 fauxlink::lib ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -namespace eval fauxlink::system { - #*** !doctools - #[subsection {Namespace fauxlink::system}] - #[para] Internal functions that are not part of the API - - - -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide fauxlink [namespace eval fauxlink { - variable pkg fauxlink - variable version - set version 0.1.0 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/modpod-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/modpod-0.1.0.tm deleted file mode 100644 index fd6b00ec..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/modpod-0.1.0.tm +++ /dev/null @@ -1,705 +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) 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 windows platform for non-existance) - #This is presumably related to // being interpreted as a network path - 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 - if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { - puts stderr "modpod stub>>> tcl::zipfs::mount failed.\nbut old api: tcl::zipfs::mount succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" - puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" - } - } - if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { - puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n 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 $modfile" - error $msg - } else { - 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/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/modpod-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/modpod-0.1.1.tm deleted file mode 100644 index afa3be2a..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/modpod-0.1.1.tm +++ /dev/null @@ -1,697 +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) 2024 -# -# @@ Meta Begin -# Application modpod 0.1.1 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin modpod_module_modpod 0 0.1.1] -#[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" - #} - - #old tar connect mechanism - review - not needed? - 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 - #//review - set modpod [::modpod::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 - } - } - - #zipfile is a pure zip at this point - ie no script/exe header - proc make_zip_modpod {args} { - set argd [punk::args::get_dict { - -offsettype -default "file" -choices {archive file} -help "Whether zip offsets are relative to start of file or start of zip-data within the file. - 'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip, - but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip) - info-zip's 'zip -A' can sometimes convert archive-relative to file-relative. - -offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'" - *values -min 2 -max 2 - zipfile -type path -minlen 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" - outfile -type path -minlen 1 -help "path to output file. Name should be of the form packagename-version.tm" - } $args] - set zipfile [dict get $argd values zipfile] - set outfile [dict get $argd values outfile] - set opt_offsettype [dict get $argd opts -offsettype] - - - set mount_stub [string map [list %offsettype% $opt_offsettype] { - #zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. - #Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. - #generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% - 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 properly 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 windows platform for non-existance) - #This is presumably related to // being interpreted as a network path - 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 - if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { - puts stderr "modpod stub>>> tcl::zipfs::mount failed.\nbut old api: tcl::zipfs::mount succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" - puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" - } - } - if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { - puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n 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 (and zipfs not available either)" - append msg \n "If neither zipfs or vfs::zip are available - 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 $modfile" - error $msg - } else { - 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 supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating? - append mount_stub \x1A - modpod::system::make_mountable_zip $zipfile $outfile $mount_stub $opt_offsettype - - } - - #*** !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 - - #zipfile here is plain zip - no script/exe prefix part. - proc make_mountable_zip {zipfile outfile mount_stub {offsettype "file"}} { - set inzip [open $zipfile r] - fconfigure $inzip -encoding iso8859-1 -translation binary - set out [open $outfile w+] - fconfigure $out -encoding iso8859-1 -translation binary - puts -nonewline $out $mount_stub - set stuboffset [tell $out] - lappend report "sfx stub size: $stuboffset" - fcopy $inzip $out - close $inzip - - set size [tell $out] - lappend report "tmfile : [file tail $outfile]" - lappend report "output size : $size" - lappend report "offsettype : $offsettype" - - if {$offsettype eq "file"} { - #make zip offsets relative to start of whole file including prepended script. - #(same offset structure as Tcl's 'zipfs mkimg' as at 2024-10) - #we aren't adding any new files/folders so we can edit the offsets in place - - #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 tailsearch_start 0 - } else { - set tailsearch_start [expr {$size - 65559}] - } - seek $out $tailsearch_start - set data [read $out] - #EOCD - End of Central Directory record - #PK\5\6 - 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 - set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] - - lappend report "kitfile-relative START-OF-EOCD: $filerelative_eocd_posn" - - seek $out $filerelative_eocd_posn - 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 {$filerelative_eocd_posn+16}] - - #adjust offset of start of central directory by the length of our sfx stub - puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $stuboffset}]] - flush $out - - seek $out $filerelative_eocd_posn - 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)" - - #PK\1\2 - #33639248 dec = 0x02014b50 - central directory 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)+$stuboffset}]] - - #verify: - flush $out - seek $out $current_file - set fileheader [read $out 46] - lappend report "old $x(offset) + $stuboffset" - 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.1 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/modpod-0.1.2.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/modpod-0.1.2.tm deleted file mode 100644 index aa27ebce..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/modpod-0.1.2.tm +++ /dev/null @@ -1,702 +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) 2024 -# -# @@ Meta Begin -# Application modpod 0.1.2 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin modpod_module_modpod 0 0.1.2] -#[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" - #} - - #old tar connect mechanism - review - not needed? - proc connect {args} { - puts stderr "modpod::connect--->>$args" - set argd [punk::args::get_dict { - @id -id ::modpod::connect - -type -default "" - @values -min 1 -max 1 - path -type string -minsize 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 - #//review - set modpod [::modpod::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 - } - } - - #zipfile is a pure zip at this point - ie no script/exe header - proc make_zip_modpod {args} { - set argd [punk::args::get_dict { - @id -id ::modpod::lib::make_zip_modpod - -offsettype -default "archive" -choices {archive file} -help\ - "Whether zip offsets are relative to start of file or start of zip-data within the file. - 'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip, - but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip) - info-zip's 'zip -A' can sometimes convert archive-relative to file-relative. - -offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'" - @values -min 2 -max 2 - zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" - outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" - } $args] - set zipfile [dict get $argd values zipfile] - set outfile [dict get $argd values outfile] - set opt_offsettype [dict get $argd opts -offsettype] - - - set mount_stub [string map [list %offsettype% $opt_offsettype] { - #zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. - #Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. - #generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% - 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 properly 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 windows platform for non-existance) - #This is presumably related to // being interpreted as a network path - 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 - if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { - puts stderr "modpod stub>>> tcl::zipfs::mount failed.\nbut old api: tcl::zipfs::mount succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" - puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" - } - } - if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { - puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n 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 (and zipfs not available either)" - append msg \n "If neither zipfs or vfs::zip are available - 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 $modfile" - error $msg - } else { - 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 supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating? - append mount_stub \x1A - modpod::system::make_mountable_zip $zipfile $outfile $mount_stub $opt_offsettype - - } - - #*** !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 - - #zipfile here is plain zip - no script/exe prefix part. - proc make_mountable_zip {zipfile outfile mount_stub {offsettype "archive"}} { - set inzip [open $zipfile r] - fconfigure $inzip -encoding iso8859-1 -translation binary - set out [open $outfile w+] - fconfigure $out -encoding iso8859-1 -translation binary - puts -nonewline $out $mount_stub - set stuboffset [tell $out] - lappend report "stub size: $stuboffset" - fcopy $inzip $out - close $inzip - - set size [tell $out] - lappend report "tmfile : [file tail $outfile]" - lappend report "output size : $size" - lappend report "offsettype : $offsettype" - - if {$offsettype eq "file"} { - #make zip offsets relative to start of whole file including prepended script. - #same offset structure as Tcl's 'zipfs mkimg' as at 2024-10 - #not editable by 7z,nanazip,peazip - - #we aren't adding any new files/folders so we can edit the offsets in place - - #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 tailsearch_start 0 - } else { - set tailsearch_start [expr {$size - 65559}] - } - seek $out $tailsearch_start - set data [read $out] - #EOCD - End of Central Directory record - #PK\5\6 - 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 - set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] - - lappend report "kitfile-relative START-OF-EOCD: $filerelative_eocd_posn" - - seek $out $filerelative_eocd_posn - 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 {$filerelative_eocd_posn+16}] - - #adjust offset of start of central directory by the length of our sfx stub - puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $stuboffset}]] - flush $out - - seek $out $filerelative_eocd_posn - 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)" - - #PK\1\2 - #33639248 dec = 0x02014b50 - central directory 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)+$stuboffset}]] - - #verify: - flush $out - seek $out $current_file - set fileheader [read $out 46] - lappend report "old $x(offset) + $stuboffset" - 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.2 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/natsort-0.1.1.5.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/natsort-0.1.1.5.tm deleted file mode 100644 index 0e4260b8..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/natsort-0.1.1.5.tm +++ /dev/null @@ -1,1894 +0,0 @@ -#! /usr/bin/env tclsh - - -package require flagfilter -namespace import ::flagfilter::check_flags - -namespace eval natsort { - proc scriptdir {} { - set possibly_linked_script [file dirname [file normalize [file join [info script] ...]]] - if {[file isdirectory $possibly_linked_script]} { - return $possibly_linked_script - } else { - return [file dirname $possibly_linked_script] - } - } - tcl::tm::add [scriptdir] -} - - -namespace eval natsort { - variable stacktrace_on 0 - - proc do_error {msg {then error}} { - #note we exit or error out even if debug selected - as every do_error call is meant to interrupt code processing at the site of call - #this is not just a 'logging' call even though it has log-like descriptors - lassign $then type code - if {$code eq ""} { - set code 1 - } - set type [string tolower $type] - set levels [list debug info notice warn error critical] - if {$type in [concat $levels exit]} { - puts stderr "|$type> $msg" - } else { - puts stderr "|>natsort_call_err> unable to interpret 2nd argument to do_error: '$then' should be one of '$levels' or 'exit '" - } - if {$::tcl_interactive} { - #may not always be desirable - but assumed to be more useful not to exit despite request, to aid in debugging - if {[string tolower $type] eq "exit"} { - puts stderr " (exit suppressed due to tcl_interactive - raising error instead)" - if {![string is digit -strict $code]} { - puts stderr "|>natsort_call_err> unable to interpret 2nd argument to do_error: '$then' should be: 'exit '" - } - } - return -code error $msg - } else { - if {$type ne "exit"} { - return -code error $msg - } else { - if {[string is digit -strict $code]} { - exit $code - } else { - puts stderr "|>natsort_call_err> unable to interpret 2nd argument to do_error: '$then' should be 'error' or 'exit '" - return -code error $msg - } - } - } - } - - - - - - - variable debug 0 - variable testlist - set testlist { - 00.test-firstposition.txt - 0001.blah.txt - 1.test-sorts-after-all-leadingzero-number-one-equivs.txt - 1010.thousand-and-ten.second.txt - 01010.thousand-and-ten.first.txt - 0001.aaa.txt - 001.zzz.txt - 08.octal.txt-last-octal - 008.another-octal-first-octal.txt - 08.again-second-octal.txt - 001.a.txt - 0010.reconfig.txt - 010.etc.txt - 005.etc.01.txt - 005.Etc.02.txt - 005.123.abc.txt - 200.somewhere.txt - 2zzzz.before-somewhere.txt - 00222-after-somewhere.txt - 005.00010.abc.txt - 005.a3423bc.00010.abc.txt - 005.001.abc.txt - 005.etc.1010.txt - 005.etc.010.txt - 005.etc.10.txt - " 005.etc.10.txt" - 005.etc.001.txt - 20.somewhere.txt - 4611686018427387904999999999-bignum.txt - 4611686018427387903-bigishnum.txt - 9223372036854775807-bigint.txt - etca-a - etc-a - etc2-a - a0001blah.txt - a010.txt - winlike-sort-difference-0.1.txt - winlike-sort-difference-0.1.1.txt - a1.txt - b1-a0001blah.txt - b1-a010.txt - b1-a1.txt - -a1.txt - --a1.txt - --a10.txt - 2.high-two.yml - 02.higher-two.yml - reconfig.txt - _common.stuff.txt - CASETEST.txt - casetest.txt - something.txt - some~thing.txt - someathing.txt - someThing.txt - thing.txt - thing_revised.txt - thing-revised.txt - "thing revised.txt" - "spacetest.txt" - " spacetest.txt" - " spacetest.txt" - "spacetest2.txt" - "spacetest 2.txt" - "spacetest02.txt" - name.txt - name2.txt - "name .txt" - "name2 .txt" - blah.txt - combined.txt - a001.txt - .test - .ssh - "Feb 10.txt" - "Feb 8.txt" - 1ab23v23v3r89ad8a8a8a9d.txt - "Folder (10)/file.tar.gz" - "Folder/file.tar.gz" - "Folder (1)/file (1).tar.gz" - "Folder (1)/file.tar.gz" - "Folder (01)/file.tar.gz" - "Folder1/file.tar.gz" - "Folder(1)/file.tar.gz" - - } - lappend testlist "Some file.txt" - lappend testlist " Some extra file1.txt" - lappend testlist " Some extra file01.txt" - lappend testlist " some extra file1.txt" - lappend testlist " Some extra file003.txt" - lappend testlist " Some file.txt" - lappend testlist "Some extra file02.txt" - lappend testlist "Program Files (x86)" - lappend testlist "01999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999991-bigger-pathologically-bignum.txt" - lappend testlist "199999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-pathologically-bignum.txt" - lappend testlist "29999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-smaller-pathologically-bignum.txt" - lappend testlist "199999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-pathologically-bignum.txt with (more 1.txt" - lappend testlist "199999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-pathologically-bignum.txt with (more 01.txt" - lappend testlist "a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1.pathological-num-nonnum-swapping-leadzero-should-be-first.txt" - lappend testlist "a1a1a1a1a1a1a1a1a1a1a1a01a1a1a1a1a1a1a1a1a1a1a1a1.pathological-num-nonnum-swapping-leadzero-should-be-first.txt" - lappend testlist "b1b1b1b1.txt" - lappend testlist "b1b01z1z1.txt" - lappend testlist "c1c111c1.txt" - lappend testlist "c1c1c1c1.txt" - - namespace eval overtype { - proc right {args} { - # @d !todo - implement overflow, length checks etc - - if {[llength $args] < 2} { - error {usage: ?-overflow [1|0]? undertext overtext} - } - foreach {undertext overtext} [lrange $args end-1 end] break - - set opt(-overflow) 0 - array set opt [lrange $args 0 end-2] - - - set olen [string length $overtext] - set ulen [string length $undertext] - - if {$opt(-overflow)} { - return [string range $undertext 0 end-$olen]$overtext - } else { - if {$olen > $ulen} { - set diff [expr {$olen - $ulen}] - return [string range $undertext 0 end-$olen][string range $overtext 0 end-$diff] - } else { - return [string range $undertext 0 end-$olen]$overtext - } - } - } - proc left {args} { - # @c overtype starting at left (overstrike) - # @c can/should we use something like this?: 'format "%-*s" $len $overtext - - if {[llength $args] < 2} { - error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} - } - foreach {undertext overtext} [lrange $args end-1 end] break - - set opt(-ellipsis) 0 - set opt(-ellipsistext) {...} - set opt(-overflow) 0 - array set opt [lrange $args 0 end-2] - - - set len [string length $undertext] - set overlen [string length $overtext] - set diff [expr {$overlen - $len}] - - #puts stdout "====================>overtype: datalen:$len overlen:$overlen diff:$diff" - #puts stdout "====================>overtype: data: $overtext" - if {$diff > 0} { - if {$opt(-overflow)} { - return $overtext - } else { - if {$opt(-ellipsis)} { - return [overtype::left [string range $overtext 0 [expr {$len -1}]] $opt(-ellipsistext)] - } else { - return [string range $overtext 0 [expr {$len -1}]] - } - } - } else { - return "$overtext[string range $undertext $overlen end]" - } - } - - } - - #considered using hex to make large numbers more compact for viewing in debug output - but it's not that much shorter and probably obscures more than it helps. - proc hex2dec {largeHex} { - #todo - use punk::lib::hex2dec - (scan supports ll so can do larger hex values directly) - set res 0 - set largeHex [string map [list _ ""] $largeHex] - if {[string length $largeHex] <=7} { - #scan can process up to FFFFFFF and does so quickly - return [scan $largeHex %x] - } - foreach hexDigit [split $largeHex {}] { - set new 0x$hexDigit - set res [expr {16*$res + $new}] - } - return $res - } - proc dec2hex {decimalNumber} { - format %4.4llX $decimalNumber - } - - #punk::lib::trimzero - proc trimzero {number} { - set trimmed [string trimleft $number 0] - if {[string length $trimmed] == 0} { - set trimmed 0 - } - return $trimmed - } - #todo - consider human numeric split - #e.g consider SI suffixes k|KMGTPEZY in that order - - #in this context, for natural sorting - numeric segments don't contain underscores or other punctuation such as . - + etc. - #review - what about unicode equivalents such as wide numerals \UFF10 to \UFF19? unicode normalization? - proc split_numeric_segments {name} { - set segments [list] - while {[string length $name]} { - if {[scan $name {%[0-9]%n} chunk len] == 2} { - lappend segments $chunk - set name [string range $name $len end] - } - if {[scan $name {%[^0-9]%n} chunk len] == 2} { - lappend segments $chunk - set name [string range $name $len end] - } - } - return $segments - } - - proc padleft {str count {ch " "}} { - set val [string repeat $ch $count] - append val $str - set diff [expr {max(0,$count - [string length $str])}] - set offset [expr {max(0,$count - $diff)}] - set val [string range $val $offset end] - } - - - # Sqlite may have limited collation sequences available in default builds. - # with custom builds - there may be others such as 'natsort' - see https://sqlite.org/forum/forumpost/e4dc6f3331 - # This is of limited use with the few builtin collations available in 2023 ie binary,nocase & rtrim - # but may provide a quicker,flexible sort option, especially if/when more collation sequences are added to sqlite - # There are also prebuilt packages such as sqlite3-icu which allows things like "SELECT icu_load_collation('en_AU', 'australian');" - proc sort_sqlite {stringlist args} { - package require sqlite3 - - - set args [check_flags -caller natsort_sqlite -defaults [list -db :memory: -collate nocase -winlike 0 -topchars "\uFFFF" -debug 0 -splitchars [list / . - _] -extras {all}] -values $args] - set db [string trim [dict get $args -db]] - set collate [string trim [dict get $args -collate]] - set debug [string trim [dict get $args -debug]] - set topchars [string trim [dict get $args -topchars]] - - set topdot [expr {"." in $topchars}] - set topunderscore [expr {"_" in $topchars}] - - - sqlite3 db_sort_basic $db - set orderedlist [list] - db_sort_basic eval [string map [list %collate% $collate] {create table sqlitesort(index0 text COLLATE %collate%, name text COLLATE %collate%)}] - foreach nm $stringlist { - set segments [split_numeric_segments $nm] - set index "" - set s 0 - foreach seg $segments { - if {($s == 0) && ![string length [string trim $seg]]} { - #don't index leading space - } elseif {($s == 0) && ($topunderscore) && [string match _* [string trim $seg]]} { - append index "[padleft "0" 5]-d -100 topunderscore " - append index [string trim $seg] - } elseif {($s == 0) && ($topdot) && [string match .* [string trim $seg]]} { - append index "[padleft "0" 5]-d -50 topdot " - append index [string trim $seg] - } else { - if {[string is digit [string trim $seg]]} { - set basenum [trimzero [string trim $seg]] - set lengthindex "[padleft [string length $basenum] 5]-d" - append index "$lengthindex " - #append index [padleft $basenum 40] - append index $basenum - } else { - append index [string trim $seg] - } - } - incr s - } - puts stdout ">>$index" - db_sort_basic eval {insert into sqlitesort values($index,$nm)} - } - db_sort_basic eval [string map [list %collate% $collate] {select name from sqlitesort order by index0 COLLATE %collate% ASC, name COLLATE %collate% ASC }] { - lappend orderedlist $name - } - db_sort_basic close - return $orderedlist - } - - proc get_leading_char_count {str char} { - #todo - something more elegant? regex? - set count 0 - foreach c [split $str "" ] { - if {$c eq $char} { - incr count - } else { - break - } - } - return $count - } - proc stacktrace {} { - set stack "Stack trace:\n" - for {set i 1} {$i < [info level]} {incr i} { - set lvl [info level -$i] - set pname [lindex $lvl 0] - append stack [string repeat " " $i]$pname - - if {![catch {info args $pname} pargs]} { - foreach value [lrange $lvl 1 end] arg $pargs { - - if {$value eq ""} { - if {$arg != 0} { - info default $pname $arg value - } - } - append stack " $arg='$value'" - } - } else { - append stack " !unknown vars for $pname" - } - - append stack \n - } - return $stack - } - - proc get_char_count {str char} { - #faster than lsearch on split for str of a few K - expr {[string length $str]-[string length [string map [list $char {}] $str]]} - } - - proc build_key {chunk splitchars topdict tagconfig debug} { - variable stacktrace_on - if {$stacktrace_on} { - puts stderr "+++>[stacktrace]" - } - - set index_map [list - "" _ ""] - #e.g - need to maintain the order - #a b.txt - #a book.txt - #ab.txt - #abacus.txt - - - set original_splitchars [dict get $tagconfig original_splitchars] - - # tag_dashes test moved from loop - review - set tag_dashes 0 - if {![string length [dict get $tagconfig last_part_text_tag]]} { - #winlike - set tag_dashes 1 - } - if {("-" ni $original_splitchars)} { - set tag_dashes 1 - } - if {$debug >= 3} { - puts stdout "START build_key chunk : $chunk" - puts stdout "START build_key splitchars : $splitchars $topdict $tagconfig NO tag dashes" - } - - - ## index_map will have no effect if we've already split on the char anyway(?) - #foreach m [dict keys $index_map] { - # if {$m in $original_splitchars} { - # dict unset index_map $m - # } - #} - - #if {![string length $chunk]} return - - set result "" - if {![llength $splitchars]} { - #no more structural splits - but we need to examine numeric/non-numeric segments at the lowest level. - # we are at a leaf in the recursive split hierarchy - - set s "" ;#we never actually split on "" (unless that was put in splitchars.. but it probably shouldn't be) - set parts [list $chunk] ;#important to treat as list or leading/trailing whitespace lost - - - } else { - set s [lindex $splitchars 0] - if {"spudbucket$s" in "[split $chunk {}]"} { - error "dead-branch spudbucket" - set partindex [build_key $chunk [lrange $splitchars 1 end] $topdict $tagconfig $debug] - if {[dict get $tagconfig showsplits]} { - set pfx "(1${s}=)" ;# = sorts before _ - set partindex ${pfx}$partindex - } - - return $partindex - } else { - set parts_below_index "" - - if {$s ni [split $chunk ""]} { - #$s can be an empty string - set parts [list $chunk] - } else { - set parts [split $chunk $s] ;#whitespace preserved - even if splitting on s that is not in string. - } - #assert - we have a splitchar $s that is in the chunk - so at least one part - if {(![string length $s] || [llength $parts] == 0)} { - error "buld_key assertion false empty split char and/or no parts" - } - - set pnum 1 ;# 1 based for clarity of reading index in debug output - set subpart_count [llength $parts] - - set sub_splits [lrange $splitchars 1 end] ;#pass same splitchars to each subpart - foreach p $parts { - set partindex [build_key $p $sub_splits $topdict $tagconfig $debug] - set lastpart [expr {$pnum == $subpart_count}] - - - ####################### - set showsplits [dict get $tagconfig showsplits] - #split prefixing experiment - maybe not suitable for general use - as it affects sort order - #note that pfx must be consistent until last one, no matter how many partnumbers there are in total. - # we don't want to influence sort order before reaching end. - #e.g for: - #(1.=)... - #(1._)...(2._)...(3.=) - #(1._)...(2.=) - #Note that this is probably more suitable for highly structure dependant sorts where the results are maybe less.. natural. - if {$showsplits} { - if {$lastpart} { - set pfx "(${pnum}${s}_" - #set pfx "(${pnum}${s}=)" ;# = sorts before _ - } else { - set pfx "(${pnum}${s}_" - } - append parts_below_index $pfx - } - ####################### - - if {$lastpart} { - if {[string length $p] && [string is digit $p]} { - set last_part_tag "<22${s}>" - } else { - set last_part_tag "<33${s}>" - } - - set last_part_text_tag [dict get $tagconfig last_part_text_tag] - #for -winlike 1 there is no tag configured. Windows explorer likes to put things in the order: - # module-0.1.1.tm - # module-0.1.1.2.tm - # module-0.1.tm - # arguably -winlike 0 is more natural/human - # module-0.1.tm - # module-0.1.1.tm - # module-0.1.1.2.tm - - if {[string length $last_part_text_tag]} { - #replace only the first text-tag (<30>) from the subpart_index - if {[string match "<30?>*" $partindex]} { - #give textual string index a specific tag for last part in split only. e.g <130> for lower than integers - set partindex "<130>[string range $partindex 5 end]" - } - #append parts_below_index $last_part_tag - } - #set partindex $last_part_tag$partindex - - - } - append parts_below_index $partindex - - - - if {$showsplits} { - if {$lastpart} { - set suffix "${pnum}${s}=)" ;# = sorts before _ - } else { - set suffix "${pnum}${s}_)" - } - append parts_below_index $suffix - } - - - incr pnum - } - append parts_below_index "" ;# don't add anything at the tail that may perturb sort order - - if {$debug >= 3} { - set pad [string repeat " " 20] - puts stdout "END build_key chunk : $chunk " - puts stdout "END build_key splitchars : $splitchars $topdict $tagconfig NO tag dashes" - puts stdout "END build_key ret below_index: $parts_below_index" - } - return $parts_below_index - - - } - } - - - - #puts stdout ">>>chunk:'$chunk'<<< split-on:$s parts: '$parts' splitchars: $splitchars -topdict:$topdict" - - - - - - #if {$chunk eq ""} { - # puts "___________________________________________!!!____" - #} - #puts stdout "-->chunk:$chunk $s parts:$parts" - - #puts stdout "---chunk:'$chunk' part:'$part' parts:'$parts' s:'$s'" - - - - - set segments [split_numeric_segments $chunk] ;#! - set stringindex "" - set segnum 0 - foreach seg $segments { - #puts stdout "=================---->seg:$seg segments:$segments" - #-strict ? - if {[string length $seg] && [string is digit $seg]} { - set basenum [trimzero [string trim $seg]] - set lengthindex "[padleft [string length $basenum] 4]d" - #append stringindex "<20>$lengthindex $basenum $seg" - } else { - set c1 [string range $seg 0 0] - #puts stdout "==============> c1'$c1' topdict: $topdict stringindex:$stringindex" - - if {$c1 in [dict keys $topdict]} { - set tag [dict get $topdict $c1] - #append stringindex "${tag}$c1" - #set seg [string range $seg 1 end] - } - #textindex - set leader "<30>" - set idx $seg - set idx [string trim $idx] - set idx [string tolower $idx] - set idx [string map $index_map $idx] - - - - - - #set the X-c count to match the length of the index - not the raw data - set lengthindex "[padleft [string length $idx] 4]c" - - #append stringindex "${leader}$idx $lengthindex $texttail" - } - } - - if {[llength $parts] != 1} { - error "build_key assertion fail llength parts != 1 parts:$parts" - } - - set segtail_clearance_buffer " " ;#space to clear other split indicators if using showsplits - set segtail $segtail_clearance_buffer - append segtail "\[" - set grouping "" - set pnum 0 - foreach p $parts { - set sublen_list [list] - set subsegments [split_numeric_segments $p] - set i 0 - - set partsorter "" - foreach sub $subsegments { - ##don't trim spaces here - it would be inconsistent. Some subs are pure whitespace - others have internal whitespace. e.g "a4 400b a b2" becomes "a 4 { } 400 {b a b} 2" - #mapping away all whitespace would be consistent, but not necessarily desirable. If it's in the index_map it'll happen anyway - so we don't do it manually here except for evaluating conditions. - set test_trim [string trim $sub] - set str $sub - set str [string tolower $str] - set str [string map $index_map $str] - if {[string length $test_trim] && [string is digit $test_trim]} { - append partsorter [trimzero $str] - } else { - append partsorter "$str" - } - append partsorter - } - - - foreach sub $subsegments { - - if {[string length $sub] && [string is digit $sub]} { - set basenum [trimzero [string trim $sub]] - set subequivs $basenum - set lengthindex "[padleft [string length $subequivs] 4]d " - set idx "$lengthindex [padleft $basenum 10]" ;#todo - cycle through data and determine longest - set tail [overtype::left [string repeat " " 10] $sub] - #set tail "" - } else { - set idx "" - - - set lookahead [lindex $subsegments $i+1] - if {![string length $lookahead]} { - set zeronum "[padleft 0 4]d0" - } else { - set zeronum "" - } - set subequivs $sub - #set subequivs [string trim $subequivs] - set subequivs [string tolower $subequivs] - set subequivs [string map $index_map $subequivs] - - append idx $subequivs - append idx $zeronum - - set idx $subequivs - - - # - - set ch "-" - if {$tag_dashes} { - #puts stdout "____TAG DASHES" - #winlike - set numleading [get_leading_char_count $seg $ch] - if {$numleading > 0} { - set texttail "<31-leading[padleft $numleading 4]$ch>" - } else { - set texttail "<30>" - } - set numothers [expr {[get_char_count $seg $ch] - $numleading}] - if {$debug >= 2} { - puts stdout "____dashcount: [get_char_count $seg $ch] numothers: $numothers" - } - if {$numothers > 0} { - append texttail "<31-others[padleft $numothers 4]$ch>" - } else { - append textail "<30>" - } - } else { - set texttail "<30>" - } - - - - - #set idx $partsorter - set tail "" - #set tail [string tolower $sub] ;#raw - #set tail $partsorter - #append tail ":[string tolower $p]" ;#we need the whole part - even though it makes the index much larger. !todo - tagconfig switch to toggle case sensitive sorting - } - - append grouping "$idx $tail|$s" - incr i - } - - - - - - if {$p eq ""} { - # no subsegments.. - set zeronum "[padleft 0 4]d0" - #append grouping "\u000$zerotail" - append grouping ".$zeronum" - } - - #append grouping | - #append grouping $s - #foreach len $sublen_list { - # append segtail "<[padleft $len 3]>" - #} - incr pnum - } - set grouping [string trimright $grouping $s] - append grouping "[padleft [llength $parts] 4]" - append segtail $grouping - - - #append segtail " <[padleft [llength $parts] 4]>" - - append segtail "\]" - - - #if {[string length $seg] && [string is digit $seg]} { - # append segtail "<20>" - #} else { - # append segtail "<30>" - #} - append stringindex $segtail - - incr segnum - - - - - lappend indices $stringindex - - if {[llength $indices] > 1} { - puts stderr "INDICES [llength $indices]: $stringindex" - error "build_key assertion error deadconcept indices" - } - - #topchar handling on splitter characters - #set c1 [string range $chunk 0 0] - if {$s in [dict keys $topdict]} { - set tag [dict get $topdict $s] - set joiner [string map [list ">" "$s>"] ${tag}] - #we have split on this character $s so if the first part is empty string then $s was a leading character - # we need to bring a tag out front for this, or it will be dominated by the leading sections-remaing tag - # (since the empty string produces no tag of it's own - ?) - if {[string length [lindex $parts 0]] == 0} { - set prefix ${joiner} - } else { - set prefix "" - } - } else { - #use standard character-data positioning tag if no override from topdict - set joiner "<30J>$s" - set prefix "" - } - - - set contentindex $prefix[join $indices $joiner] - if {[string length $s]} { - set split_indicator "" - } else { - set split_indicator "" - - } - if {![string length $s]} { - set s ~ - } - - #return "[overtype::left [string repeat { } 80] $contentindex][overtype::left [string repeat { } 10] [list $s $chunk]]" - #return $contentindex$split_indicator - #return [overtype::left [string repeat - 40] $contentindex] - - if {$debug >= 3} { - puts stdout "END build_key chunk : $chunk" - puts stdout "END build_key splitchars : $splitchars $topdict $tagconfig NO tag dashes" - puts stdout "END build_key ret contentidx : $contentindex" - } - return $contentindex - } - - #---------------------------------------- - #line-processors - data always last argument - opts can be empty string - #all processor should accept empty opts and ignore opts if they don't use them - proc _lineinput_as_tcl1 {opts line} { - set out "" - foreach i $line { - append out "$i " - } - set out [string range $out 0 end-1] - return $out - } - #should be equivalent to above - proc _lineinput_as_tcl {opts line} { - return [concat {*}$line] - } - #will put extra tcl quoting if it was already tcl-shaped e.g text "a" -> {"a"} - proc _lineoutput_as_tcl {opts line} { - return [regexp -inline -all {\S+} $line] - } - - proc _lineinput_as_raw {opts line} { - return $line - } - proc _lineoutput_as_raw {opts line} { - return $line - } - - #words is opposite of tcl - proc _lineinput_as_words {opts line} { - #wordlike_parts - return [regexp -inline -all {\S+} $line] - } - proc _lineoutput_as_words {opts line} { - return [concat {*}$line] - } - - #opts same as tcllib csv::split - except without the 'line' element - #?-alternate? ?sepChar? ?delChar? - proc _lineinput_as_csv {opts line} { - package require csv - if {[lindex $opts 0] eq "-alternate"} { - return [csv::split -alternate $line {*}[lrange $opts 1 end]] - } else { - return [csv::split $line {*}$opts] - } - } - #opts same as tcllib csv::join - #?sepChar? ?delChar? ?delMode? - proc _lineoutput_as_csv {opts line} { - package require csv - return [csv::join $line {*}$opts] - } - #---------------------------------------- - proc sort {stringlist args} { - #puts stdout "natsort::sort args: $args" - variable debug - if {![llength $stringlist]} return - - #allow pass through of the check_flags flag -debugargs so it can be set by the caller - set debugargs 0 - if {[set posn [lsearch $args -debugargs]] >=0} { - if {$posn == [llength $args]-1} { - #-debugargs at tail of list - set debugargs 1 - } else { - set debugargs [lindex $args $posn+1] - } - } - - #-return flagged|defaults doesn't work Review. - #flagfilter global processor/allocator not working 2023-08 - set args [check_flags \ - -caller natsort::sort \ - -return supplied|defaults \ - -debugargs $debugargs \ - -defaults [list -collate nocase \ - -winlike 0 \ - -splits "\uFFFF" \ - -topchars {. _} \ - -showsplits 1 \ - -sortmethod ascii \ - -collate "\uFFFF" \ - -inputformat raw \ - -inputformatapply {index data} \ - -inputformatoptions "" \ - -outputformat raw \ - -outputformatoptions "" \ - -cols "\uFFFF" \ - -debug 0 -db "" -stacktrace 0 -splits "\uFFFF" -showsplits 0] \ - -required {all} \ - -extras {none} \ - -commandprocessors {} \ - -values $args] - - #csv unimplemented - - set winlike [dict get $args -winlike] - set topchars [dict get $args -topchars] - set cols [dict get $args -cols] - set debug [dict get $args -debug] - set stacktrace [dict get $args -stacktrace] - set showsplits [dict get $args -showsplits] - set splits [dict get $args -splits] - set sortmethod [dict get $args -sortmethod] - set opt_collate [dict get $args -collate] - set opt_inputformat [dict get $args -inputformat] - set opt_inputformatapply [dict get $args -inputformatapply] - set opt_inputformatoptions [dict get $args -inputformatoptions] - set opt_outputformat [dict get $args -outputformat] - set opt_outputformatoptions [dict get $args -outputformatoptions] - dict unset args -showsplits - dict unset args -splits - if {$debug} { - puts stdout "natsort::sort processed_args: $args" - if {$debug == 1} { - puts stdout "natsort::sort - try also -debug 2, -debug 3" - } - } - - #set sortmethod "-dictionary" ;# sorts a2b before a001b - possibly other strangenesses that are hard to reason about - - if {$sortmethod in [list dictionary ascii]} { - set sortmethod "-$sortmethod" - # -ascii is default for tcl lsort. - } else { - set sortmethod "-ascii" - } - - set allowed_collations [list nocase] - if {$opt_collate ne "\uFFFF"} { - if {$opt_collate ni $allowed_collations} { - error "natsort::sort unknown value for -collate option. Only acceptable value(s): $allowed_collations" - } - set nocaseopt "-$opt_collate" - } else { - set nocaseopt "" - } - set allowed_inputformats [list tcl raw csv words] - if {$opt_inputformat ni $allowed_inputformats} { - error "natsort::sort unknown value for -inputformat option. Only acceptable value(s): $allowed_inputformats" - } - set allowed_outputformats [list tcl raw csv words] - if {$opt_inputformat ni $allowed_outputformats} { - error "natsort::sort unknown value for -outputformat option. Only acceptable value(s): $allowed_outputformats" - } - - # - set winsplits [list / . _] - set commonsplits [list / . _ -] - #set commonsplits [list] - - set tagconfig [dict create] - dict set tagconfig last_part_text_tag "<19>" - if {$winlike} { - set splitchars $winsplits - #windows explorer sorts leading spaces at the top - which doesn't seem very helpful for keeping things together - but the explorer doesn't seem able to create leading spaces anyway. - set wintop [list "(" ")" { } {.} {_}] ;#windows specific order - foreach t $topchars { - if {$t ni $wintop} { - lappend wintop $t - } - } - set topchars $wintop - dict set tagconfig last_part_text_tag "" - } else { - set splitchars $commonsplits - } - if {$splits ne "\uFFFF"} { - set splitchars $splits - } - dict set tagconfig original_splitchars $splitchars - dict set tagconfig showsplits $showsplits - - #create topdict - set i 0 - set topdict [dict create] - foreach c $topchars { - incr i ;#start at 01 so that 00 reserved for final-split tag (allows x-0.1.txt to sort above x-0.1.1.txt by default. Use tagconfig to change, or choose -winlike 1 for explorer-like sorting) - dict set topdict $c "<0$i>" - } - set keylist [list] - - - if {$opt_inputformat eq "tcl"} { - set lineinput_transform [list _lineinput_as_tcl $opt_inputformatoptions] - } elseif {$opt_inputformat eq "csv"} { - set lineinput_transform [list _lineinput_as_csv $opt_inputformatoptions] - } elseif {$opt_inputformat eq "raw"} { - set lineinput_transform [list _lineinput_as_raw $opt_inputformatoptions] - } elseif {$opt_inputformat eq "words"} { - set lineinput_transform [list _lineinput_as_words $opt_inputformatoptions] - } - if {$opt_outputformat eq "tcl"} { - set lineoutput_transform [list _lineoutput_as_tcl $opt_outputformatoptions] - } elseif {$opt_outputformat eq "csv"} { - set lineoutput_transform [list _lineoutput_as_csv $opt_outputformatoptions] - } elseif {$opt_outputformat eq "raw"} { - set lineoutput_transform [list _lineoutput_as_raw $opt_outputformatoptions] - } elseif {$opt_outputformat eq "words"} { - set lineoutput_transform [list _lineoutput_as_words $opt_outputformatoptions] - } - - - if {("data" in $opt_inputformatapply) || ("index" in $opt_inputformatapply)} { - if {$opt_inputformat eq "raw"} { - set tf_stringlist $stringlist - } else { - set tf_stringlist [list] - foreach v $stringlist { - lappend tf_stringlist [{*}$lineinput_transform $v] - } - } - if {"data" in $opt_inputformatapply} { - set tf_data_stringlist $tf_stringlist - } else { - set tf_data_stringlist $stringlist - } - if {"index" in $opt_inputformatapply} { - set tf_index_stringlist $tf_stringlist - } else { - set tf_index_stringlist $stringlist - } - } else { - set tf_data_stringlist $stringlist - set tf_index_stringlist $stringlist - } - - - - if {$stacktrace} { - puts stdout [natsort::stacktrace] - set natsort::stacktrace_on 1 - } - if {$cols eq "\uFFFF"} { - set colkeys [lmap v $stringlist {}] - } else { - set colkeys [list] - foreach v $tf_index_stringlist { - set lineparts $v - set k [list] - foreach c $cols { - lappend k [lindex $lineparts $c] - } - lappend colkeys [join $k "_"] ;#use a common-split char - Review - } - } - #puts stdout "colkeys: $colkeys" - - if {$opt_inputformat eq "raw"} { - #no inputformat was applied - can just use stringlist - foreach value $stringlist ck $colkeys { - set contentindex [build_key $value $splitchars $topdict $tagconfig $debug] - set colindex [build_key $ck $splitchars $topdict $tagconfig $debug] - lappend keylist ${colindex}-${contentindex}-$value ;#note: entire raw value used for final sort disambiguation (can be whitespace that was ignored in indexing) - } - } else { - foreach keyinput $tf_index_stringlist datavalue $tf_data_stringlist ck $colkeys { - #data may or may not have been transformed - #column index may or may not have been built with transformed data - - set contentindex [build_key $keyinput $splitchars $topdict $tagconfig $debug] - set colindex [build_key $ck $splitchars $topdict $tagconfig $debug] - lappend keylist ${colindex}-${contentindex}-$datavalue ;#note: entire value used for final sort disambiguation (can be whitespace that was ignored in indexing) - } - } - #puts stderr "keylist: $keylist" - - ################################################################################################### - # Use the generated keylist to do the actual sorting - # select either the transformed or raw data as the corresponding output - ################################################################################################### - if {[string length $nocaseopt]} { - set sortcommand [list lsort $sortmethod $nocaseopt -indices $keylist] - } else { - set sortcommand [list lsort $sortmethod -indices $keylist] - } - if {$opt_outputformat eq "raw"} { - #raw output means no further transformations - it doesn't mean there wasn't a transform applied on the input side - #use the tf_data_stringlist in the output - which will be the same as the input stringlist if no input transform applied for data. - #(Also - it may or may not have been *sorted* on transformed data depending on whether 'index' was in $opt_inputformatapply) - foreach idx [{*}$sortcommand] { - lappend result [lindex $tf_data_stringlist $idx] - } - } else { - #we need to apply an output format - #The data may or may not have been transformed at input - foreach idx [{*}$sortcommand] { - lappend result [{*}$lineoutput_transform [lindex $tf_data_stringlist $idx]] - } - } - ################################################################################################### - - - - - - if {$debug >= 2} { - set screen_width 250 - set max_val 0 - set max_idx 0 - ##### calculate colum widths - foreach i [{*}$sortcommand] { - set len_val [string length [lindex $stringlist $i]] - if {$len_val > $max_val} { - set max_val $len_val - } - set len_idx [string length [lindex $keylist $i]] - if {$len_idx > $max_idx} { - set max_idx $len_idx - } - } - #### - set l_width [expr {$max_val + 1}] - set leftcol [string repeat " " $l_width] - set r_width [expr {$screen_width - $l_width - 1}] - set rightcol [string repeat " " $r_width] - set str [overtype::left $leftcol RAW] - puts stdout " $str Index with possibly transformed data at tail" - foreach i [{*}$sortcommand] { - #puts stdout "|d> [overtype::left $leftcol [lindex $stringlist $i] ] [lindex $keylist $i]" - set index [lindex $keylist $i] - set len_idx [string length $index] - set rowcount [expr {$len_idx / $r_width}] - if {($len_idx % $r_width) > 0} { - incr rowcount - } - set rows [list] - for {set r 0} {$r < $rowcount} {incr r} { - lappend rows [string range $index 0 $r_width-$r] - set index [string range $index $r_width end] - } - - set r 0 - foreach idxpart $rows { - if {$r == 0} { - #use the untransformed stringlist - set str [overtype::left $leftcol [lindex $stringlist $i]] - } else { - set str [overtype::left $leftcol ...]] - } - puts stdout " $str $idxpart" - incr r - } - #puts stdout "|> '[lindex $stringlist $i]'" - #puts stdout "|> [lindex $keylist $i]" - } - - puts stdout "|debug> topdict: $topdict" - puts stdout "|debug> splitchars: $splitchars" - } - return $result - } - - - - #Note that although leading whitespace isn't a commonly used feature of filesystem names - it's possible at least on FreeBSD,windows and linux so we should try to handle it sensibly. - proc sort_experiment {stringlist args} { - package require sqlite3 - - variable debug - set args [check_flags -caller natsort::sort \ - -defaults [dict create -db :memory: -collate nocase -nullvalue "->NULL<" -winlike 0 -topchars [list] -debug 0] \ - -extras {all} \ - -values $args] - set db [string trim [dict get $args -db]] - set collate [string trim [dict get $args -collate]] - set winlike [string trim [dict get $args -winlike]] - set debug [string trim [dict get $args -debug]] - set nullvalue [string trim [dict get $args -nullvalue]] - - - set topchars [string trim [dict get $args -topchars]] - - set topdot [expr {"." in $topchars}] - set topunderscore [expr {"_" in $topchars}] - - - sqlite3 db_natsort2 $db - #-- - #our table must handle the name with the greatest number of numeric/non-numeric splits. - #This means a single list member with pathological naming e.g a1a1a1a1a1a1a1a1a1a1a1.txt could greatly extend the number of columns and indices and affect performance. - #review: could be optimised to aggregate the tail into a single index, as the the extra columns won't assist in ordering, but make the table and query bigger. - # we should probably determine the longest common sequence of splits in the input list and add only one more index for the segment after that. - set maxsegments 0 - #-- - set prefix "idx" - - #note - there will be more columns in the sorting table than segments. - # (a segment equals one of the numeric & non-numeric string portions returned from 'split_numeric_sgements') - #--------------------------- - # consider - # a123b.v1.2.txt - # a123b.v1.3beta1.txt - # these have the following segments: - # a 123 b.v 1 . 2 .txt - # a 123 b.v 1 . 3 beta 1 .txt - #--------------------------- - # The first string has 7 segments (numbered 0 to 6) - # the second string has 9 segments - # - # for example when the data has any elements in a segment position that are numeric (e.g 0001 123) - # - then an index column with numeric equivalents will be created (e.g 0001 becomes 1), and any non-numeric values in that column will get mapped to a negative value (for special cases) or a high value such as NULL (with NULLS LAST sql support) - # - # when a segment - - #cycle through all strings - we cannot build tabledef as we go because the column type depends on whether all segments for a particular column are text vs int-equivalent. - array set segmentinfo {} - foreach nm $stringlist { - set segments [split_numeric_segments $nm] - if {![string length [string trim [lindex $segments 0]]]} { - if {[string is digit [string trim [lindex $segments 1]]]} { - #name is whitespace followed by a digit - special case - ignore the whitespace for numbers only. (whitespace still goes through to name column though) - set segments [lrange $segments 1 end] - } - } - - - set c 0 ;#start of index columns - if {[llength $segments] > $maxsegments} { - set maxsegments [llength $segments] - } - foreach seg $segments { - set seg [string trim $seg] - set column_exists [info exists segmentinfo($c,type)] - if {[string is digit $seg]} { - if {$column_exists} { - #override it (may currently be text or int) - set segmentinfo($c,type) "int" - } else { - #new column - set segmentinfo($c,name) ${prefix}$c - set segmentinfo($c,type) "int" - } - } else { - #text never overrides int - if {!$column_exists} { - set segmentinfo($c,name) ${prefix}$c - set segmentinfo($c,type) "text" - } - } - incr c - } - } - if {$debug} { - puts stdout "Largest number of num/non-num segments in data: $maxsegments" - #parray segmentinfo - } - - # - set tabledef "" - set ordered_column_names [list] - set ordered_segmentinfo_tags [lsort -dictionary [array names segmentinfo *]] - foreach k $ordered_segmentinfo_tags { - lassign [split $k ,] c tag - if {$tag eq "type"} { - set type [set segmentinfo($k)] - if {$type eq "int"} { - append tabledef "$segmentinfo($c,name) int," - } else { - append tabledef "$segmentinfo($c,name) text COLLATE $collate," - } - append tabledef "raw$c text COLLATE $collate," - lappend ordered_column_names $segmentinfo($c,name) - lappend ordered_column_names raw$c ;#additional index column not in segmentinfo - } - if {$tag eq "name"} { - #lappend ordered_column_names $segmentinfo($k) - } - } - append tabledef "name text" - - #puts stdout "tabledef:$tabledef" - - - db_natsort2 eval [string map [list %tabledef% $tabledef] {create table natsort(%tabledef%)}] - - - foreach nm $stringlist { - array unset intdata - array set intdata {} - array set rawdata {} - #init array and build sql values string - set sql_insert "insert into natsort values(" - for {set i 0} {$i < $maxsegments} {incr i} { - set intdata($i) "" - set rawdata($i) "" - append sql_insert "\$intdata($i),\$rawdata($i)," - } - append sql_insert "\$nm" ;#don't manipulate name value in any way - e.g must leave all whitespace as the sort must return exactly the same elements as in the original list. - append sql_insert ")" - - set segments [split_numeric_segments $nm] - if {![string length [string trim [lindex $segments 0]]]} { - if {[string is digit [string trim [lindex $segments 1]]]} { - #name is whitespace followed by a digit - special case - ignore the whitespace for numbers only. (whitespace still goes through to name column though) - set segments [lrange $segments 1 end] - } - } - set values "" - set c 0 - foreach seg $segments { - if {[set segmentinfo($c,type)] eq "int"} { - if {[string is digit [string trim $seg]]} { - set intdata($c) [trimzero [string trim $seg]] - } else { - catch {unset intdata($c)} ;#set NULL - sorts last - if {($c == 0) && ($topunderscore) && [string match _* [string trim $seg]]} { - set intdata($c) -100 - } - if {($c == 0) && ($topdot) && [string match .* [string trim $seg]]} { - set intdata($c) -50 - } - } - set rawdata($c) [string trim $seg] - } else { - #pure text column - #set intdata($c) [string trim $seg] ;#ignore leading/trailing whitespace - we sort first on trimmed version, then refine with the sort on rawdata index - #catch {unset indata($c)} - set indata($c) [string trim $seg] - set rawdata($c) $seg - } - #set rawdata($c) [string trim $seg]# - #set rawdata($c) $seg - incr c - } - db_natsort2 eval $sql_insert - } - - set orderedlist [list] - - if {$debug} { - db_natsort2 eval {select * from pragma_table_info('natsort')} rowdata { - parray rowdata - } - } - set orderby "order by " - - foreach cname $ordered_column_names { - if {[string match "idx*" $cname]} { - append orderby "$cname ASC NULLS LAST," - } else { - append orderby "$cname ASC," - } - } - append orderby " name ASC" - #append orderby " NULLS LAST" ;#?? - - #e.g "order by idx0 ASC, raw0 ASC, idx1 ASC .... name ASC" - if {$debug} { - puts stdout "orderby clause: $orderby" - } - db_natsort2 eval [string map [list %orderby% $orderby] {select * from natsort %orderby%}] rowdata { - set line "- " - #parray rowdata - set columnnames $rowdata(*) - #puts stdout "columnnames: $columnnames" - #[lsort -dictionary [array names rowdata] - append line "$rowdata(name) \n" - foreach nm $columnnames { - if {$nm ne "name"} { - append line "$nm: $rowdata($nm) " - } - } - #puts stdout $line - #puts stdout "$rowdata(name)" - lappend orderedlist $rowdata(name) - } - - db_natsort2 close - return $orderedlist - } -} - - -#application section e.g this file might be linked from /usr/local/bin/natsort -namespace eval natsort { - namespace import ::flagfilter::check_flags - - proc called_directly_namematch {} { - global argv0 - #see https://wiki.tcl-lang.org/page/main+script - #trailing ... let's us resolve symlinks in last component of the path (could be something else like ___ but ... seems unlikely to collide with anything in the filesystem) - if {[info exists argv0] - && - [file dirname [file normalize [file join [info script] ...]]] - eq - [file dirname [file normalize [file join $argv0 ...]]] - } { - return 1 - } else { - #puts stdout "norm info script: [file dirname [file normalize [file join [info script] ...]]]" - #puts stdout "norm argv0 : [file dirname [file normalize [file join $argv0 ...]]]" - return 0 - } - } - #Review issues around comparing names vs using inodes (esp with respect to samba shares) - proc called_directly_inodematch {} { - global argv0 - if {[info exists argv0] - && [file exists [info script]] && [file exists $argv0]} { - file stat $argv0 argv0Info - file stat [info script] scriptInfo - expr {$argv0Info(dev) == $scriptInfo(dev) - && $argv0Info(ino) == $scriptInfo(ino)} - } else { - return 0 - } - } - - set is_namematch [called_directly_namematch] - set is_inodematch [called_directly_inodematch] - #### - #review - reliability of mechanisms to determine direct calls - # we don't want application being called when being used as a library, but we need it to run if called directly or from symlinks etc - #-- choose a policy and leave the others commented. - #set is_called_directly $is_namematch - #set is_called_directly $is_inodematch - set is_called_directly [expr {$is_namematch || $is_inodematch}] - #set is_called_directly [expr {$is_namematch && $is_inodematch}] - ### - - - #puts stdout "called_directly_name: [called_directly_namematch] called_directly_inode: [called_directly_inodematch]" - - - # - - - proc test_pass_fail_message {pass {additional ""}} { - variable test_fail_msg - variable test_pass_msg - if {$pass} { - puts stderr $test_pass_msg - } else { - puts stderr $test_fail_msg - } - puts stderr $additional - } - - variable test_fail_msg "XXXXXXXXXXXX FAIL XXXXXXXXXXXXX" - variable test_pass_msg "------------ PASS -------------" - proc test_sort_1 {args} { - package require struct::list - puts stderr "---$args" - set args [check_flags -caller natsort:test_sort_1 -defaults [list -collate nocase -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 ] -values $args] - - puts stderr "test_sort_1 got args: $args" - - set unsorted_input { - 2.2.2 - 2.2.2.2 - 1a.1.1 - 1a.2.1.1 - 1.12.1 - 1.2.1.1 - 1.02.1.1 - 1.002b.1.1 - 1.1.1.2 - 1.1.1.1 - } - set input { -1.1.1 -1.1.1.2 -1.002b.1.1 -1.02.1.1 -1.2.1.1 -1.12.1 -1a.1.1 -1a.2.1.1 -2.2.2 -2.2.2.2 - } - - set sorted [natsort::sort $input {*}$args] - set is_match [struct::list equal $input $sorted] - - set msg "windows-explorer order" - - test_pass_fail_message $is_match $msg - puts stdout [string repeat - 40] - puts stdout INPUT - puts stdout [string repeat - 40] - foreach item $input { - puts stdout $item - } - puts stdout [string repeat - 40] - puts stdout OUTPUT - puts stdout [string repeat - 40] - foreach item $sorted { - puts stdout $item - } - test_pass_fail_message $is_match $msg - return [expr {!$is_match}] - } - proc test_sort_showsplits {args} { - package require struct::list - - set args [check_flags -caller natsort:test_sort_1 \ - -defaults [list -collate nocase -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 1 ] \ - -extras {all} \ - -values $args] - - set input1 { - a-b.txt - a.b.c.txt - b.c-txt - } - - - set input2 { - a.b.c.txt - a-b.txt - b.c-text - } - - foreach {msg testlist } [list "custom-order" $input1 "windows-explorer (should work with -winlike 1)" $input2] { - set sorted [natsort::sort $testlist {*}$args] - set is_match [struct::list equal $testlist $sorted] - - test_pass_fail_message $is_match $msg - puts stderr "INPUT" - puts stderr "[string repeat - 40]" - foreach item $testlist { - puts stdout $item - } - puts stderr "[string repeat - 40]" - puts stderr "OUTPUT" - puts stderr "[string repeat - 40]" - foreach item $sorted { - puts stdout $item - } - - test_pass_fail_message $is_match $msg - } - - #return [expr {!$is_match}] - - } - - #tcl dispatch order - non flag items up front - #trailing flags are paired even if supplied as solo flags e.g -l becomes -l 1 - proc commandline_ls {args} { - set operands [list] - set posn 0 - foreach a $args { - if {![string match -* $a]} { - lappend operands $a - } else { - set flag1_posn $posn - break - } - incr posn - } - set args [lrange $args $flag1_posn end] - - - set debug 0 - set posn [lsearch $args -debug] - if {$posn > 0} { - if {[lindex $args $posn+1]} { - set debug [lindex $args $posn+1] - } - } - if {$debug} { - puts stderr "|debug>commandline_ls got $args" - } - - #if first operand not supplied - replace it with current working dir - if {[lindex $operands 0] eq "\uFFFF"} { - lset operands 0 [pwd] - } - - set targets [list] - foreach op $operands { - if {$op ne "\uFFFF"} { - set opchars [split [file tail $op] ""] - if {"?" in $opchars || "*" in $opchars} { - lappend targets $op - } else { - #actual file or dir - set targetitem $op - set targetitem [file normalize $op] - if {![file exists $targetitem]} { - if {$debug} { - puts stderr "|debug>commandline_ls Unable to access path '$targetitem'" - } - } - lappend targets $targetitem - if {$debug} { - puts stderr "|debug>commandline_ls listing for $targetitem" - } - } - } - } - set args [check_flags -caller commandline_ls \ - -return flagged|defaults \ - -debugargs 0 \ - -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 -algorithm sort] \ - -required {all} \ - -extras {all} \ - -soloflags {-v -l} \ - -commandprocessors {} \ - -values $args ] - if {$debug} { - puts stderr "|debug>args: $args" - } - - - set algorithm [dict get $args -algorithm] - dict unset args -algorithm - - set allfolders [list] - set allfiles [list] - foreach item $targets { - if {[file exists $item]} { - if {[file type $item] eq "directory"} { - set dotfolders [glob -nocomplain -directory $item -type {d} -tail .*] - set folders [glob -nocomplain -directory $item -type {d} -tail *] - set allfolders [concat $allfolders $dotfolders $folders] - - set dotfiles [glob -nocomplain -directory $item -type {f} -tail .*] - set files [glob -nocomplain -directory $item -type {f} -tail *] - set allfiles [concat $allfiles $dotfiles $files] - } else { - #file (or link?) - set files [glob -nocomplain -directory [file dirname $item] -tail [file tail $item]] - set allfiles [concat $allfiles $files] - } - } else { - set folders [glob -nocomplain -directory $item -type {d} -tail [file tail $item]] - set allfolders [concat $allfolders $folders] - set files [glob -nocomplain -directory [file dirname $item] -tail [file tail $item]] - set allfiles [concat $allfiles $files] - } - } - - - set sorted_folders [natsort::sort $allfolders {*}$args] - set sorted_files [natsort::sort $allfiles {*}$args] - - foreach fold $sorted_folders { - puts stdout $fold - } - foreach file $sorted_files { - puts stdout $file - } - - return "-- ok printed to stdout [llength $sorted_folders] folders and [llength $sorted_files] files --" - } - - package require argp - argp::registerArgs commandline_test { - { -showsplits boolean 0} - { -stacktrace boolean 0} - { -debug boolean 0} - { -winlike boolean 0} - { -db string ":memory:"} - { -collate string "nocase"} - { -algorithm string "sort"} - { -topchars string "\uFFFF"} - { -testlist string {10 1 30 3}} - } - argp::setArgsNeeded commandline_test {-stacktrace} - proc commandline_test {test args} { - variable testlist - puts stdout "commandline_test got $args" - argp::parseArgs opts - puts stdout "commandline_test got [array get opts]" - set args [check_flags -caller natsort_commandline \ - -return flagged|defaults \ - -defaults [list -db :memory: -collate nocase -testlist $testlist -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] \ - -values $args] - - if {[string tolower $test] in [list "1" "true"]} { - set test "sort" - } else { - if {![llength [info commands $test]]} { - error "test $test not found" - } - } - dict unset args -test - set stacktrace [dict get $args -stacktrace] - # dict unset args -stacktrace - - set argtestlist [dict get $args -testlist] - dict unset args -testlist - - - set debug [dict get $args -debug] - - set collate [dict get $args -collate] - set db [dict get $args -db] - set winlike [dict get $args -winlike] - set topchars [dict get $args -topchars] - - - puts stderr "|test>-----start natsort::$test--- input list size : [llength $argtestlist]" - #set resultlist [$test $argtestlist -db $db -collate $collate -topchars $topchars -winlike $winlike] - set resultlist [$test $argtestlist {*}$args] - foreach nm $resultlist { - puts stdout $nm - } - puts stdout "|test>-----end natsort::$test--- sorted list size: [llength $resultlist]" - return "test end" - } - proc commandline_runtests {runtests args} { - set argvals [check_flags -caller commandline_runtests \ - -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits "\uFFFF" -runtests 1] \ - -values $args] - - puts stderr "runtests args: $argvals" - - #set runtests [dict get $argvals -runtests] - dict unset argvals -runtests - dict unset argvals -algorithm - - puts stderr "runtests args: $argvals" - #exit 0 - - set test_prefix "::natsort::test_sort_" - - if {$runtests eq "1"} { - set runtests "*" - } - - - set testcommands [info commands ${test_prefix}${runtests}] - if {![llength $testcommands]} { - puts stderr "No test commands matched -runtests argument '$runtests'" - puts stderr "Use 1 to run all tests" - set alltests [info commands ${test_prefix}*] - puts stderr "Valid tests are:" - - set prefixlen [string length $test_prefix] - foreach t $alltests { - set shortname [string range $t $prefixlen end] - puts stderr "$t = -runtests $shortname" - } - - } else { - foreach cmd $testcommands { - puts stderr [string repeat - 40] - puts stderr "calling $cmd with args: '$argvals'" - puts stderr [string repeat - 40] - $cmd {*}$argvals - } - } - exit 0 - } - proc help {args} { - puts stdout "natsort::help got '$args'" - return "Help not implemented" - } - proc natsort_pipe {args} { - #PIPELINE to take input list on stdin and write sorted list to stdout - #strip - from arglist - #set args [check_flags -caller natsort_pipeline \ - # -return all \ - # -defaults [list -db :memory: -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] \ - # -values $args] - - - set debug [dict get $args -debug] - if {$debug} { - puts stderr "|debug> natsort_pipe got args:'$args'" - } - set algorithm [dict get $args -algorithm] - dict unset args -algorithm - - set proclist [info commands ::natsort::sort*] - set algos [list] - foreach p $proclist { - lappend algos [namespace tail $p] - } - if {$algorithm ni [list {*}$proclist {*}$algos]} { - do_error "valid sort mechanisms: $algos" 2 - } - - - set input_list [list] - while {![eof stdin]} { - if {[gets stdin line] > 0} { - lappend input_list $line - } else { - if {[eof stdin]} { - - } else { - after 10 - } - } - } - - if {$debug} { - puts stderr "|debug> received [llength $input_list] list elements" - } - - set resultlist [$algorithm $input_list {*}$args] - if {$debug} { - puts stderr "|debug> returning [llength $resultlist] list elements" - } - foreach r $resultlist { - puts stdout $r - } - #exit 0 - - } - if {($is_called_directly)} { - set cmdprocessors { - {helpfinal {match "^help$" dispatch natsort::help}} - {helpfinal {sub -topic default "NONE"}} - } - #set args [check_flags \ - # -caller test1 \ - # -debugargs 2 \ - # -return arglist \ - # -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] \ - # -required {none} \ - # -extras {all} \ - # -commandprocessors $cmdprocessors \ - # -values $::argv ] - interp alias {} do_filter {} ::flagfilter::check_flags - - #mashopts are generally single-letter opts that can be run together e.g -l -d as -ld - set cmdprocessors { - {helpcmd {match "^help$" dispatch natsort::help singleopts {-v}}} - {helpcmd {sub -operand default \uFFFF singleopts {-l}}} - {lscmd {match "^ls$" dispatch natsort::commandline_ls dispatchtype tcl dispatchglobal 1 mashopts {-l -a} singleopts {-l -a} pairopts {} longopts {--color=always}}} - {lscmd {sub dir default "\uFFFF"}} - {lscmd {sub dir2 default "\uFFFF"}} - {lscmd {sub dir3 default "\uFFFF"}} - {lscmd {sub dir4 default "\uFFFF"}} - {lscmd {sub dir5 default "\uFFFF"}} - {lscmd {sub dir6 default "\uFFFF"}} - {runtests {match "^-tests$" dispatch natsort::commandline_runtests singleopts {-l}}} - {runtests {sub testname default "1" singleopts {-l}}} - {pipecmd {match "^-$" dispatch natsort::natsort_pipe dispatchtype tcl}} - } - set arglist [do_filter \ - -debugargs 0 \ - -debugargsonerror 2 \ - -caller cline_dispatch1 \ - -return all \ - -soloflags {-v -x} \ - -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 ] \ - -required {all} \ - -extras {all} \ - -commandprocessors $cmdprocessors \ - -values $::argv ] - - - #mashopts are generally single-letter opts that can be run together e.g -l -d as -ld - set cmdprocessors { - {testcmd {match "^test$" dispatch natsort::commandline_test singleopts {-l}}} - {testcmd {sub testname default "1" singleopts {-l}}} - } - set arglist [check_flags \ - -debugargs 0 \ - -caller cline_dispatch2 \ - -return all \ - -soloflags {-v -l} \ - -defaults [list -collate nocase -algorithm sort -testlist "1 2 3 10" -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 ] \ - -required {all} \ - -extras {all} \ - -commandprocessors $cmdprocessors \ - -values $::argv ] - - - - - #set cmdprocessors [list] - #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors $cmdprocessors -values $::argv ] - - #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors {-cmd {-cmd -cmdarg1 -default "."} {-cmd -cmdarg2 -default j}} -values $::argv ] - #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors {{-cmd -default help} {-cmd -cmdarg1 -default "."} {-cmd -cmdarg2 -default j}} -values $::argv ] - #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors {ls {ls lsdir -default "\uFFFF"}} -values $::argv ] - - exit 0 - - if {$::argc} { - - } - } -} - - -package provide natsort [namespace eval natsort { - variable version - set version 0.1.1.5 -}] - - diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/oolib-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/oolib-0.1.1.tm deleted file mode 100644 index ecf2cca9..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/oolib-0.1.1.tm +++ /dev/null @@ -1,200 +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.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]} { - 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? - 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/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/oolib-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/oolib-0.1.tm deleted file mode 100644 index 3756fceb..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/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/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.1.tm deleted file mode 100644 index 91ed77ec..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/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/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.2.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.2.tm deleted file mode 100644 index 0bdd4ca0..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/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/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.3.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.3.tm deleted file mode 100644 index ef12e956..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.3.tm +++ /dev/null @@ -1,3655 +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.3 -# Meta platform tcl -# Meta license BSD -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin overtype_module_overtype 0 1.6.3] -#[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 renderspace {args} { - #*** !doctools - #[call [fun overtype::renderspace] [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::renderspace 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 - } - } - } - set test_mode 1 ;#try to eliminate - # ---------------------------- - - #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" || $opt_height eq "\uFFEF"} { - lassign [blocksize $underblock] _w colwidth _h colheight - if {$opt_width ne "\uFFEF"} { - set colwidth $opt_width - } - if {$opt_height ne "\uFFEF"} { - set colheight $opt_height - } - } else { - set colwidth $opt_width - set colheight $opt_height - } - - # -- --- --- --- - #REVIEW - do we need ansi resets in the underblock? - if {$underblock eq ""} { - set underlines [lrepeat $colheight ""] - } else { - set underlines [split $underblock \n] - } - #if {$underblock eq ""} { - # set blank "\x1b\[0m\x1b\[0m" - # #set underlines [list "\x1b\[0m\x1b\[0m"] - # set underlines [lrepeat $colheight $blank] - #} else { - # #lines_as_list -ansiresets 1 will do nothing if -ansiresets 1 isn't specified - REVIEW - # 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::renderspace 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::renderspace 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::renderspace 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 [punk::ansi::stripansi $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::renderspace 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] - } - - #overtype::right is for a rendered ragged underblock and a rendered ragged overblock - #ie we can determine the block width for bost by examining the lines and picking the longest. - # - 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] - } - - proc left {args} { - overtype::block -blockalign left {*}$args - } - #overtype a (possibly ragged) underblock with a (possibly ragged) overblock - proc block {args} { - variable default_ellipsis_horizontal - # @d !todo - implement overflow, length checks etc - - 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 - - set defaults [dict create\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -overflow 0\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -textalign "left"\ - -textvertical "top"\ - -blockalign "left"\ - -blockalignbias left\ - -blockvertical "top"\ - ] - set argsflags [lrange $args 0 end-2] - dict for {k v} $argsflags { - switch -- $k { - -blockalignbias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -textalign - -blockalign - -blockvertical {} - default { - set known_opts [dict keys $defaults] - error "overtype::block 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_textalign [dict get $opts -textalign] - set opt_blockalign [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 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)}] - - switch -- $opt_blockalign { - left { - set left_exposed 0 - } - right { - set left_exposed $under_exposed_max - } - centre { - 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 -blockalignbias]] eq "left"} { - set left_exposed $beforehalf - } else { - #bias to the right - set left_exposed [expr {$beforehalf + 1}] - } - } - } else { - set left_exposed 0 - } - } - default { - 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}] - #puts xxx - append undertext [string repeat { } $udiff] - } - if {$overtext_datalen < $overblock_width} { - set odiff [expr {$overblock_width - $overtext_datalen}] - switch -- $opt_textalign { - 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] - set overflow_right [dict get $rinfo overflow_right] - set unapplied [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] - 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::block -blockalign right $rendered $opt_ellipsistext] - } - } - - #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] - set overflow_right [dict get $rinfo overflow_right] - set unapplied [dict get $rinfo unapplied] - 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 ""\ - -cp437 0\ - -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 - -cp437 - -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 [dict get $opts -cp437] - foreach e [dict get $opts -experimental] { - switch -- $e { - test_mode { - set test_mode 1 - set cp437_glyphs 1 - } - } - } - set test_mode 1 ;#try to elminate - 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 { - - #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] - } - 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.3 -}] -return - -#*** !doctools -#[manpage_end] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.4.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.4.tm deleted file mode 100644 index 42876322..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.4.tm +++ /dev/null @@ -1,3685 +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.4 -# Meta platform tcl -# Meta license BSD -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin overtype_module_overtype 0 1.6.4] -#[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] - -#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. - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !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 tcl::string::range -# - need to extract and replace ansi codes? - -tcl::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 "..." - tcl::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" -} - -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{|}~). - 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 [tcl::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 [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] - } - 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) -tcl::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 - } - } - } -} - -tcl::namespace::eval overtype { - #*** !doctools - #[subsection {Namespace overtype}] - #[para] Core API functions for overtype - #[list_begin definitions] - - - - #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. - #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 renderspace {args} { - #*** !doctools - #[call [fun overtype::renderspace] [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 opts [tcl::dict::create\ - -bias ignored\ - -width \uFFEF\ - -height \uFFEF\ - -startcolumn 1\ - -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] - foreach {k v} $argsflags { - switch -- $k { - -looplimit - -width - -height - -startcolumn - -bias - -wrap - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -appendlines - -transparent - -exposed1 - -exposed2 - -experimental { - tcl::dict::set opts $k $v - } - default { - error "overtype::renderspace unknown option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - #set opts [tcl::dict::merge $defaults $argsflags] - # -- --- --- --- --- --- - 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 [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 [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 - # -- --- --- --- --- --- - - # ---------------------------- - # -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 [tcl::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 - } - } - } - set test_mode 1 ;#try to eliminate - # ---------------------------- - - #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 underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $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" || $opt_height eq "\uFFEF"} { - lassign [blocksize $underblock] _w colwidth _h colheight - if {$opt_width ne "\uFFEF"} { - set colwidth $opt_width - } - if {$opt_height ne "\uFFEF"} { - set colheight $opt_height - } - } else { - set colwidth $opt_width - set colheight $opt_height - } - - # -- --- --- --- - #REVIEW - do we need ansi resets in the underblock? - if {$underblock eq ""} { - set underlines [lrepeat $colheight ""] - } else { - set underlines [split $underblock \n] - } - #if {$underblock eq ""} { - # set blank "\x1b\[0m\x1b\[0m" - # #set underlines [list "\x1b\[0m\x1b\[0m"] - # set underlines [lrepeat $colheight $blank] - #} else { - # #lines_as_list -ansiresets 1 will do nothing if -ansiresets 1 isn't specified - REVIEW - # 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 [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 {[tcl::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 [tcl::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 [tcl::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 [tcl::dict::create 1 ""] - #lappend replay_codes_overlay "" - set replay_codes_overlay "" - set unapplied "" - set cursor_saved_position [tcl::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 $opt_startcolumn - } - - set instruction_stats [tcl::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 {![tcl::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 [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 - 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 [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] - - - - #-- todo - detect looping properly - if {$row > 1 && $overtext ne "" && $unapplied eq $overtext && $post_render_row == $row && $instruction eq ""} { - puts stderr "overtype::renderspace loop?" - puts [ansistring VIEW $rinfo] - break - } - #-- - - if {[tcl::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 - tcl::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 {[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 [tcl::dict::get $rinfo replay_codes_overlay]$cursor_saved_attributes - #set replay_codes_overlay $cursor_saved_attributes - set cursor_saved_position [tcl::dict::create] - set cursor_saved_attributes "" - } else { - #TODO - #?restore without save? - #should move to home position and reset ansi SGR? - #puts stderr "overtype::renderspace 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 [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.. - } - 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 $opt_startcolumn - # ---------------------- - } - 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 $opt_startcolumn - 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 $opt_startcolumn - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } else { - append rendered $overflow_right - set overflow_right "" - set row $post_render_row - set col $opt_startcolumn - 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 $opt_startcolumn - - } - 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 $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] - #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 $opt_startcolumn - - - - } - } - } 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 $opt_startcolumn - } 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 $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 [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' - 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 $opt_startcolumn - 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::renderspace unhandled renderline instruction '$instruction'" - } - - } - - - if {!$opt_overflow && !$autowrap_mode} { - #not allowed to overflow column or wrap therefore we get overflow data to truncate - if {[tcl::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 {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - if {[tcl::string::trim [punk::ansi::stripansi $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::renderspace 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 :[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 - - 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 opts [tcl::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] - foreach {k v} $argsflags { - switch -- $k { - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 { - tcl::dict::set opts $k $v - } - default { - set known_opts [tcl::dict::keys $opts] - error "overtype::centre unknown option '$k'. Known options: $known_opts" - } - } - } - #set opts [tcl::dict::merge $defaults $argsflags] - # -- --- --- --- --- --- - 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 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}]] - 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 {[tcl::string::tolower [tcl::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 [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 [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 {![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 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 - } - if {$unapplied ne ""} { - append lostdata $unapplied - } - if {[tcl::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 [tcl::dict::get $rinfo result] - } - 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] - } - - #overtype::right is for a rendered ragged underblock and a rendered ragged overblock - #ie we can determine the block width for bost by examining the lines and picking the longest. - # - 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 opts [tcl::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] - tcl::dict::for {k v} $argsflags { - switch -- $k { - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -align { - tcl::dict::set opts $k $v - } - default { - set known_opts [tcl::dict::keys $opts] - error "overtype::centre unknown option '$k'. Known options: $known_opts" - } - } - } - #set opts [tcl::dict::merge $defaults $argsflags] - # -- --- --- --- --- --- - 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 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}]] - 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 [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 [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 [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - if {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set ellipsis [tcl::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 [tcl::dict::get $rinfo result] - } - 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] - } - - proc left {args} { - overtype::block -blockalign left {*}$args - } - #overtype a (possibly ragged) underblock with a (possibly ragged) overblock - proc block {args} { - variable default_ellipsis_horizontal - # @d !todo - implement overflow, length checks etc - - 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 - lassign [lrange $args end-1 end] underblock overblock - - set opts [tcl::dict::create\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -overflow 0\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -textalign "left"\ - -textvertical "top"\ - -blockalign "left"\ - -blockalignbias left\ - -blockvertical "top"\ - ] - set argsflags [lrange $args 0 end-2] - tcl::dict::for {k v} $argsflags { - switch -- $k { - -blockalignbias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -textalign - -blockalign - -blockvertical { - tcl::dict::set opts $k $v - } - default { - error "overtype::block unknown option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - # -- --- --- --- --- --- - 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 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}]] - 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)}] - - switch -- $opt_blockalign { - left { - set left_exposed 0 - } - right { - set left_exposed $under_exposed_max - } - centre { - 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 {[tcl::string::tolower [tcl::dict::get $opts -blockalignbias]] eq "left"} { - set left_exposed $beforehalf - } else { - #bias to the right - set left_exposed [expr {$beforehalf + 1}] - } - } - } else { - set left_exposed 0 - } - } - default { - 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}] - #puts xxx - append undertext [string repeat { } $udiff] - } - if {$overtext_datalen < $overblock_width} { - set odiff [expr {$overblock_width - $overtext_datalen}] - switch -- $opt_textalign { - 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 [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 [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 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 - } - if {$unapplied ne ""} { - append lostdata $unapplied - } - if {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set rendered [overtype::block -blockalign right $rendered $opt_ellipsistext] - } - } - - #if {$opt_ellipsis} { - # set show_ellipsis 1 - # if {!$opt_ellipsiswhitespace} { - # #we don't want ellipsis if only whitespace was lost - # 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 [tcl::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] - 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 [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] - } - # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### - # 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" - #} - - #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\ - -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 ""\ - -cp437 0\ - -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] - 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 { - tcl::dict::set opts $k $v - } - default { - error "overtype::renderline unknown option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - # -- --- --- --- --- --- --- --- --- --- --- --- - 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 {![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 [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 [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 [tcl::dict::get $opts -cursor_restore_attributes] - - set test_mode 0 - set cp437_glyphs [tcl::dict::get $opts -cp437] - foreach e [tcl::dict::get $opts -experimental] { - switch -- $e { - test_mode { - set test_mode 1 - set cp437_glyphs 1 - } - } - } - set test_mode 1 ;#try to elminate - 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? - tcl::dict::unset cp437_map \n - } - - set opt_transparent [tcl::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 [tcl::dict::get $opts -info] - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_exposed1 [tcl::dict::get $opts -exposed1] - set opt_exposed2 [tcl::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 - #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 - } - - 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 ""} { - 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] - } - 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 [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. - #.. 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 [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 {[tcl::string::index $c1c2 0] eq "\x1b"} { - set maybemouse [tcl::string::index $code 2] - } - - 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]} { - 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 -- [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 - } - 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 - 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] - #### - - #??? - 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 { - - #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 [tcl::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 {[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 "" - #} - # -- --- --- --- --- --- --- --- - - - #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 - - #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" - 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 [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 { - "" { - 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 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 " " - #tcl::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 [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 - 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 [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 - } - } - } 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 { - #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 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? - - 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)} - #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\ - \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 [tcl::string::cat $leadernorm [tcl::string::range $code 3 end]] - } - 7CSI - 7OSC { - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] - } - 7ESC { - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] - } - 8CSI - 8OSC { - set codenorm [tcl::string::cat $leadernorm [tcl::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 -- [tcl::string::index $codenorm end] { - M { - puts stderr "mousedown $codenorm" - } - m { - puts stderr "mouseup $codenorm" - } - } - - } - {7CSI} - {8CSI} { - 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" - #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 {[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] - #} - 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 [tcl::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 {[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 { - #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 -- [tcl::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 [tcl::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 [tcl::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 [tcl::string::map {\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 [tcl::string::trimright $outstring "\u0000"] - } - 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 [tcl::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 [tcl::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. - } - } - 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 { - return $outstring - } - #return [join $out ""] - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace overtype ---}] -} - -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} - } - 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 [tcl::dict::create\ - -transparent 1\ - -exposed 1 " "\ - -exposed 2 " "\ - ] - 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. -# -tcl::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 {[tcl::dict::exists $grapheme_widths $ch]} { - return [tcl::dict::get $grapheme_widths $ch] - } - set width [punk::char::ansifreestring_width $ch] - tcl::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 [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 {[tcl::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 {[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 - 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 [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 -} - -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 {[tcl::dict::exists $cache_is_sgr $code]} { - return [tcl::dict::get $cache_is_sgr $code] - } - set answer [punk::ansi::codetype::is_sgr $code] - tcl::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 {![tcl::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 - } - } - } - -} - - - -# -- --- --- --- --- --- --- --- --- --- --- -tcl::namespace::eval overtype { - interp alias {} ::overtype::center {} ::overtype::centre -} - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide overtype [tcl::namespace::eval overtype { - variable version - set version 1.6.4 -}] -return - -#*** !doctools -#[manpage_end] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.5.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.5.tm deleted file mode 100644 index 9363fb6d..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.5.tm +++ /dev/null @@ -1,4773 +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.5 -# Meta platform tcl -# Meta license BSD -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[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 --}] -#[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] - -#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. - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !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 tcl::string::range -# - need to extract and replace ansi codes? - -tcl::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 "..." - tcl::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" -} - -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{|}~). - 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 [tcl::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::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::ansistrip. Alternatively try punk::ansi::printing_length" - set text [punk::ansi::ansistrip $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) -tcl::namespace::eval overtype::priv { -} - -#could return larger than renderwidth -proc _get_row_append_column {row} { - #obsolete? - upvar outputlines outputlines - set idx [expr {$row -1}] - if {$row <= 1 || $row > [llength $outputlines]} { - return 1 - } else { - upvar opt_expand_right expand_right - upvar renderwidth renderwidth - set existinglen [punk::ansi::printing_length [lindex $outputlines $idx]] - set endpos [expr {$existinglen +1}] - if {$expand_right} { - return $endpos - } else { - if {$endpos > $renderwidth} { - return $renderwidth + 1 - } else { - return $endpos - } - } - } -} - -tcl::namespace::eval overtype { - #*** !doctools - #[subsection {Namespace overtype}] - #[para] Core API functions for overtype - #[list_begin definitions] - - - - #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. - #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 renderspace {args} { - #*** !doctools - #[call [fun overtype::renderspace] [arg args] ] - #[para] usage: ?-transparent [lb]0|1[rb]? ?-expand_right [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: ?-width ? ?-startcolumn ? ?-transparent [0|1|]? ?-expand_right [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} - } - set optargs [lrange $args 0 end-2] - if {[llength $optargs] % 2 == 0} { - set overblock [lindex $args end] - set underblock [lindex $args end-1] - #lassign [lrange $args end-1 end] underblock overblock - set argsflags [lrange $args 0 end-2] - } else { - set optargs [lrange $args 0 end-1] - if {[llength $optargs] %2 == 0} { - set overblock [lindex $args end] - set underblock "" - set argsflags [lrange $args 0 end-1] - } else { - error "renderspace expects opt-val pairs followed by: or just " - } - } - set opts [tcl::dict::create\ - -bias ignored\ - -width \uFFEF\ - -height \uFFEF\ - -startcolumn 1\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -expand_right 0\ - -appendlines 1\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -experimental 0\ - -cp437 0\ - -looplimit \uFFEF\ - -crm_mode 0\ - -reverse_mode 0\ - -insert_mode 0\ - -wrap 0\ - -info 0\ - -console {stdin stdout stderr}\ - ] - #expand_right is perhaps consistent with the idea of the page_size being allowed to grow horizontally.. - # it does not necessarily mean the viewport grows. (which further implies need for horizontal scrolling) - # - it does need to be within some concept of terminal width - as columns must be addressable by ansi sequences. - # - This implies the -width option value must grow if it is tied to the concept of renderspace terminal width! REVIEW. - # - further implication is that if expand_right grows the virtual renderspace terminal width - - # then some sort of reflow/rerender needs to be done for preceeding lines? - # possibly not - as expand_right is distinct from a normal terminal-width change event, - # expand_right being primarily to support other operations such as textblock::table - - #todo - viewport width/height as separate concept to terminal width/height? - #-ellipsis args not used if -wrap is true - foreach {k v} $argsflags { - switch -- $k { - -looplimit - -width - -height - -startcolumn - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - - -transparent - -exposed1 - -exposed2 - -experimental - - -expand_right - -appendlines - - -reverse_mode - -crm_mode - -insert_mode - - -cp437 - - -info - -console { - tcl::dict::set opts $k $v - } - -wrap - -autowrap_mode { - #temp alias -autowrap_mode for consistency with renderline - #todo - - tcl::dict::set opts -wrap $v - } - default { - error "overtype::renderspace unknown option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - #set opts [tcl::dict::merge $defaults $argsflags] - # -- --- --- --- --- --- - #review - expand_left for RTL text? - set opt_expand_right [tcl::dict::get $opts -expand_right] - #for repl - standard output line indicator is a dash - todo, add a different indicator for a continued line. - 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 - # -- --- --- --- --- --- - set opt_crm_mode [tcl::dict::get $opts -crm_mode] - set opt_reverse_mode [tcl::dict::get $opts -reverse_mode] - set opt_insert_mode [tcl::dict::get $opts -insert_mode] - ##### - # review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?. - set opt_autowrap_mode [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) - ##### - # -- --- --- --- --- --- - set opt_cp437 [tcl::dict::get $opts -cp437] - set opt_info [tcl::dict::get $opts -info] - - - - # ---------------------------- - # -experimental dev flag to set flags etc - # ---------------------------- - set data_mode 0 - set edit_mode 0 - set opt_experimental [tcl::dict::get $opts -experimental] - foreach o $opt_experimental { - switch -- $o { - data_mode { - set data_mode 1 - } - edit_mode { - set edit_mode 1 - } - } - } - # ---------------------------- - - - set underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - - #set underlines [split $underblock \n] - - #underblock is a 'rendered' block - so width height make sense - #only non-cursor affecting and non-width occupying ANSI codes should be present. - #ie SGR codes and perhaps things such as PM - although generally those should have been pushed to the application already - #renderwidth & renderheight were originally used with reference to rendering into a 'column' of output e.g a table column - before cursor row/col was implemented. - - if {$opt_width eq "\uFFEF" || $opt_height eq "\uFFEF"} { - lassign [blocksize $underblock] _w renderwidth _h renderheight - if {$opt_width ne "\uFFEF"} { - set renderwidth $opt_width - } - if {$opt_height ne "\uFFEF"} { - set renderheight $opt_height - } - } else { - set renderwidth $opt_width - set renderheight $opt_height - } - #initial state for renderspace 'terminal' reset - set initial_state [dict create\ - renderwidth $renderwidth\ - renderheight $renderheight\ - crm_mode $opt_crm_mode\ - reverse_mode $opt_reverse_mode\ - insert_mode $opt_insert_mode\ - autowrap_mode $opt_autowrap_mode\ - cp437 $opt_cp437\ - ] - #modes - #e.g insert_mode can be toggled by insert key or ansi IRM sequence CSI 4 h|l - #opt_startcolumn ?? - DECSLRM ? - set vtstate $initial_state - - # -- --- --- --- - #REVIEW - do we need ansi resets in the underblock? - if {$underblock eq ""} { - set underlines [lrepeat $renderheight ""] - } else { - set underblock [textblock::join_basic -- $underblock] ;#ensure properly rendered - ansi per-line resets & replays - set underlines [split $underblock \n] - } - #if {$underblock eq ""} { - # set blank "\x1b\[0m\x1b\[0m" - # #set underlines [list "\x1b\[0m\x1b\[0m"] - # set underlines [lrepeat $renderheight $blank] - #} else { - # #lines_as_list -ansiresets 1 will do nothing if -ansiresets 1 isn't specified - REVIEW - # 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 renderwidth - #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 [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 {[tcl::string::length $overblock] + 10}] - } - - #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 scheme 4 - 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 [tcl::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 [tcl::string::range [lindex $lflines end] 0 end-1] - } - #set inputchunks $lflines[unset lflines] - set inputchunks [lindex [list $lflines [unset lflines]] 0] - - } - 4 { - set inputchunks [list] - foreach ln [split $overblock \n] { - lappend inputchunks $ln\n - } - if {[llength $inputchunks]} { - lset inputchunks end [tcl::string::range [lindex $inputchunks end] 0 end-1] - } - } - } - - - - - set replay_codes_underlay [tcl::dict::create 1 ""] - #lappend replay_codes_overlay "" - set replay_codes_overlay "[punk::ansi::a]" - set unapplied "" - set cursor_saved_position [tcl::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 $opt_startcolumn - #} - - set instruction_stats [tcl::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 {![tcl::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 [tcl::string::cat [lindex $replay_codes_overlay $overidx] $overtext] - set overtext $replay_codes_overlay$overtext - if {[tcl::dict::exists $replay_codes_underlay $row]} { - set undertext [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 - set renderopts [list -experimental $opt_experimental\ - -cp437 $opt_cp437\ - -info 1\ - -crm_mode [tcl::dict::get $vtstate crm_mode]\ - -insert_mode [tcl::dict::get $vtstate insert_mode]\ - -autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\ - -reverse_mode [tcl::dict::get $vtstate reverse_mode]\ - -cursor_restore_attributes $cursor_saved_attributes\ - -transparent $opt_transparent\ - -width [tcl::dict::get $vtstate renderwidth]\ - -exposed1 $opt_exposed1\ - -exposed2 $opt_exposed2\ - -expand_right $opt_expand_right\ - -cursor_column $col\ - -cursor_row $row\ - ] - set rinfo [renderline {*}$renderopts $undertext $overtext] - - set instruction [tcl::dict::get $rinfo instruction] - tcl::dict::set vtstate crm_mode [tcl::dict::get $rinfo crm_mode] - tcl::dict::set vtstate insert_mode [tcl::dict::get $rinfo insert_mode] - tcl::dict::set vtstate autowrap_mode [tcl::dict::get $rinfo autowrap_mode] ;# - tcl::dict::set vtstate reverse_mode [tcl::dict::get $rinfo reverse_mode] - #how to support reverse_mode in rendered linelist? we need to examine all pt/code blocks and flip each SGR stack? - # - review - the answer is probably that we don't need to - it is set/reset only during application of overtext - - #Note carefully the difference betw overflow_right and unapplied. - #overflow_right may need to be included in next run before the unapplied data - #overflow_right most commonly has data when in insert_mode - 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] ;#column width of what is 'rendered' for the line - 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] - if {0 && [tcl::dict::get $vtstate reverse_mode]} { - #test branch - todo - prune - puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered" - #review - #JMN3 - set existing_reverse_state 0 - #split_codes_single is single esc sequence - but could have multiple sgr codes within one esc sequence - #e.g \x1b\[0;31;7m has a reset,colour red and reverse - set codeinfo [punk::ansi::codetype::sgr_merge [list $replay_codes_overlay] -info 1] - set codestate_reverse [dict get $codeinfo codestate reverse] - switch -- $codestate_reverse { - 7 { - set existing_reverse_state 1 - } - 27 { - set existing_reverse_state 0 - } - "" { - } - } - if {$existing_reverse_state == 0} { - set rflip [a+ reverse] - } else { - #reverse of reverse - set rflip [a+ noreverse] - } - #note that mergeresult can have multiple esc (due to unmergeables or non sgr codes) - set replay_codes_overlay [punk::ansi::codetype::sgr_merge [list [dict get $codeinfo mergeresult] $rflip]] - puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered" - } - - - - #-- todo - detect looping properly - if {$row > 1 && $overtext ne "" && $unapplied eq $overtext && $post_render_row == $row && $instruction eq ""} { - puts stderr "overtype::renderspace loop?" - puts [ansistring VIEW $rinfo] - break - } - #-- - - if {[tcl::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 - set instruction_type [lindex $instruction 0] ;#some instructions have params - tcl::dict::incr instruction_stats $instruction_type - switch -- $instruction_type { - reset { - #reset the 'renderspace terminal' (not underlying terminal) - set row 1 - set col 1 - set vtstate [tcl::dict::merge $vtstate $initial_state] - #todo - clear screen - } - {} { - #end of supplied line input - #lf included in data - set row $post_render_row - set col $post_render_col - if {![llength $unapplied_list]} { - if {$overflow_right ne ""} { - incr row - } - } else { - puts stderr "renderspace end of input line - has unapplied: [ansistring VIEW $unapplied] (review)" - } - set col $opt_startcolumn - } - 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 < $renderwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $renderwidth - } - } - - #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 < $renderwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $renderwidth - } - - } - } - restore_cursor { - #testfile belinda.ans uses this - - #puts stdout "[a+ blue bold]CURSOR_RESTORE[a]" - 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 [tcl::dict::get $rinfo replay_codes_overlay]$cursor_saved_attributes - #set replay_codes_overlay $cursor_saved_attributes - set cursor_saved_position [tcl::dict::create] - set cursor_saved_attributes "" - } else { - #TODO - #?restore without save? - #should move to home position and reset ansi SGR? - #puts stderr "overtype::renderspace 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 [tcl::dict::get $vtstate renderwidth]\ - -insert_mode [tcl::dict::get $vtstate insert_mode]\ - -autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\ - -expand_right [tcl::dict::get $opts -expand_right]\ - ""\ - $overflow_right\ - ] - set foldline [tcl::dict::get $sub_info result] - tcl::dict::set vtstate insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..? - tcl::dict::set vtstate 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.. - } - 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? - } - clear_and_move { - #e.g 2J - if {$post_render_row > [llength $outputlines]} { - set row [llength $outputlines] - } else { - set row $post_render_row - } - set col $post_render_col - set overflow_right "" ;#if we're clearing - any overflow due to insert_mode is irrelevant - set clearedlines [list] - foreach ln $outputlines { - lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $renderwidth]\x1b\[0m - if 0 { - - set lineparts [punk::ansi::ta::split_codes $ln] - set numcells 0 - foreach {pt _code} $lineparts { - if {$pt ne ""} { - foreach grapheme [punk::char::grapheme_split $pt] { - 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 { - incr numcells 1 - } - default { - if {$grapheme eq "\u0000"} { - incr numcells 1 - } else { - incr numcells [grapheme_width_cached $grapheme] - } - } - } - - } - } - } - #replays/resets each line - lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $numcells]\x1b\[0m - } - } - set outputlines $clearedlines - #todo - determine background/default to be in effect - DECECM ? - puts stderr "replay_codes_overlay: [ansistring VIEW $replay_codes_overlay]" - #lset outputlines 0 $replay_codes_overlay[lindex $outputlines 0] - - } - lf_start { - #raw newlines - # ---------------------- - #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 $opt_startcolumn - # ---------------------- - } - lf_mid { - - 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 $opt_startcolumn - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } else { - if 1 { - if {$overflow_right ne ""} { - if {$opt_expand_right} { - append rendered $overflow_right - set overflow_right "" - } else { - #review - we should really make renderline do the work...? - set overflow_width [punk::ansi::printing_length $overflow_right] - if {$visualwidth + $overflow_width <= $renderwidth} { - append rendered $overflow_right - set overflow_right "" - } else { - if {[tcl::dict::get $vtstate autowrap_mode]} { - set outputlines [linsert $outputlines $renderedrow $overflow_right] - set overflow_right "" - set row [expr {$renderedrow + 2}] - } else { - set overflow_right "" ;#abandon - } - - if {0 && $visualwidth < $renderwidth} { - puts stderr "visualwidth: $visualwidth < renderwidth:$renderwidth" - error "incomplete - abandon?" - set overflowparts [punk::ansi::ta::split_codes $overflow_right] - set remaining_overflow $overflowparts - set filled 0 - foreach {pt code} $overflowparts { - lpop remaining_overflow 0 - if {$pt ne ""} { - set graphemes [punk::char::grapheme_split $pt] - set add "" - set addlen $visualwidth - foreach g $graphemes { - set w [overtype::grapheme_width_cached $g] - if {$addlen + $w <= $renderwidth} { - append add $g - incr addlen $w - } else { - set filled 1 - break - } - } - append rendered $add - } - if {!$filled} { - lpop remaining_overflow 0 ;#pop code - } - } - set overflow_right [join $remaining_overflow ""] - } - } - } - } - set row $post_render_row - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } else { - #old version - known to work with various ansi graphics - e.g fruit.ans - # - but fails to limit lines to renderwidth when expand_right == 0 - append rendered $overflow_right - set overflow_right "" - set row $post_render_row - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } - } - } - lf_overflow { - #linefeed after renderwidth 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 - } - if {![tcl::dict::get $vtstate insert_mode]} { - assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right when not insert_mode - } - - 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 $opt_startcolumn - - } - 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} { - #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 $opt_startcolumn - } - } 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 < $renderwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $renderwidth - } - } - } - } - 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 $renderwidth - set r $post_render_row - if {$post_render_col > $renderwidth} { - set i $c - while {$i <= $post_render_col} { - if {$c == $renderwidth+1} { - incr r - if {$opt_appendlines} { - if {$r < [llength $outputlines]} { - lappend outputlines "" - } - } - set c $opt_startcolumn - } 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 $renderwidth - 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 $renderwidth - } 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 {[tcl::dict::get $vtstate autowrap_mode]} { - incr row - set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ?? - } else { - set col $post_render_col - #set unapplied "" ;#this seems wrong? - #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' - 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 {[tcl::dict::get $vtstate autowrap_mode]} { - if {$renderwidth < 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 $opt_startcolumn - incr row - } - } else { - set overflow_handled 1 - #handled by dropping entire overflow if any - if {$renderwidth < 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 - } - set_window_title { - set newtitle [lindex $instruction 1] - puts stderr "overtype::renderspace set_window_title [ansistring VIEW $newtitle] instruction '$instruction'" - # - } - reset_colour_palette { - puts stderr "overtype::renderspace instruction '$instruction' unimplemented" - } - default { - puts stderr "overtype::renderspace unhandled renderline instruction '$instruction'" - } - - } - - - if {!$opt_expand_right && ![tcl::dict::get $vtstate autowrap_mode]} { - #not allowed to overflow column or wrap therefore we get overflow data to truncate - if {[tcl::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 {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - if {[tcl::string::trim [punk::ansi::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::renderspace 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 "data_mode:$data_mode\n" - append debugmsg "opt_appendlines:$opt_appendlines\n" - append debugmsg "prev_row :[tcl::dict::get $renderopts -cursor_row]\n" - append debugmsg "prev_col :[tcl::dict::get $renderopts -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 - - 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 {!$opt_info} { - return $result - } else { - #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 - set inforesult [dict create\ - result $result\ - last_instruction $instruction\ - instruction_stats $instruction_stats\ - ] - if {$opt_info == 2} { - return [pdict -channel none inforesult] - } else { - return $inforesult - } - } - } - - #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 opts [tcl::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] - foreach {k v} $argsflags { - switch -- $k { - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 { - tcl::dict::set opts $k $v - } - default { - set known_opts [tcl::dict::keys $opts] - error "overtype::centre unknown option '$k'. Known options: $known_opts" - } - } - } - #set opts [tcl::dict::merge $defaults $argsflags] - # -- --- --- --- --- --- - 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 underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - set underlines [split $underblock \n] - #set renderwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] - lassign [blocksize $underblock] _w renderwidth _h renderheight - set overlines [split $overblock \n] - lassign [blocksize $overblock] _w overblock_width _h overblock_height - set under_exposed_max [expr {$renderwidth - $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 {[tcl::string::tolower [tcl::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 < $renderwidth} { - set udiff [expr {$renderwidth - $ulen}] - set undertext "$undertext[string repeat { } $udiff]" - } - set undertext $replay_codes_underlay$undertext - set overtext $replay_codes_overlay$overtext - - set overflowlength [expr {$overtext_datalen - $renderwidth}] - #review - right-to-left langs should elide on left! - extra option required - - if {$overflowlength > 0} { - #overlay line wider or equal - #review - we still expand_right for centred for now.. possibly should do something like -expand_leftright with ellipsis each end? - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right [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 {![tcl::dict::get $opts -overflow]} { - #lappend outputlines [tcl::string::range $overtext 0 [expr {$renderwidth - 1}]] - #set overtext [tcl::string::range $overtext 0 $renderwidth-1 ] - if {$opt_ellipsis} { - set show_ellipsis 1 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - #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 - } - if {$unapplied ne ""} { - append lostdata $unapplied - } - if {[tcl::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 [tcl::dict::get $rinfo result] - } - 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] - } - - #overtype::right is for a rendered ragged underblock and a rendered ragged overblock - #ie we can determine the block width for bost by examining the lines and picking the longest. - # - 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 opts [tcl::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] - tcl::dict::for {k v} $argsflags { - switch -- $k { - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -align { - tcl::dict::set opts $k $v - } - default { - set known_opts [tcl::dict::keys $opts] - error "overtype::centre unknown option '$k'. Known options: $known_opts" - } - } - } - #set opts [tcl::dict::merge $defaults $argsflags] - # -- --- --- --- --- --- - 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 underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - set underlines [split $underblock \n] - lassign [blocksize $underblock] _w renderwidth _h renderheight - 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,$renderwidth - $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 < $renderwidth} { - set udiff [expr {$renderwidth - $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 $replay_codes_underlay$undertext - set overtext $replay_codes_overlay$overtext - - set overflowlength [expr {$overtext_datalen - $renderwidth}] - 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 [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 [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - if {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set ellipsis $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(exapnd_right) 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 -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] - lappend outputlines [tcl::dict::get $rinfo result] - } - 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] - } - - proc left {args} { - overtype::block -blockalign left {*}$args - } - #overtype a (possibly ragged) underblock with a (possibly ragged) overblock - proc block {args} { - variable default_ellipsis_horizontal - # @d !todo - implement overflow, length checks etc - - 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 - lassign [lrange $args end-1 end] underblock overblock - - set opts [tcl::dict::create\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -overflow 0\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -textalign "left"\ - -textvertical "top"\ - -blockalign "left"\ - -blockalignbias left\ - -blockvertical "top"\ - ] - set argsflags [lrange $args 0 end-2] - tcl::dict::for {k v} $argsflags { - switch -- $k { - -blockalignbias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -textalign - -blockalign - -blockvertical { - tcl::dict::set opts $k $v - } - default { - error "overtype::block unknown option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - # -- --- --- --- --- --- - 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 underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - set underlines [split $underblock \n] - lassign [blocksize $underblock] _w renderwidth _h renderheight - 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,$renderwidth - $overblock_width)}] - - switch -- $opt_blockalign { - left { - set left_exposed 0 - } - right { - set left_exposed $under_exposed_max - } - centre { - 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 {[tcl::string::tolower [tcl::dict::get $opts -blockalignbias]] eq "left"} { - set left_exposed $beforehalf - } else { - #bias to the right - set left_exposed [expr {$beforehalf + 1}] - } - } - } else { - set left_exposed 0 - } - } - default { - 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 < $renderwidth} { - set udiff [expr {$renderwidth - $ulen}] - #puts xxx - append undertext [string repeat { } $udiff] - } - if {$overtext_datalen < $overblock_width} { - set odiff [expr {$overblock_width - $overtext_datalen}] - switch -- $opt_textalign { - 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 $replay_codes_underlay$undertext - set overtext $replay_codes_overlay$overtext - - set overflowlength [expr {$overtext_datalen - $renderwidth}] - 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 -expand_right $opt_overflow -startcolumn [expr {1 + $startoffset}] $undertext $overtext] - 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 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 - } - if {$unapplied ne ""} { - append lostdata $unapplied - } - if {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set rendered [overtype::block -blockalign right $rendered $opt_ellipsistext] - } - } - - #if {$opt_ellipsis} { - # set show_ellipsis 1 - # if {!$opt_ellipsiswhitespace} { - # #we don't want ellipsis if only whitespace was lost - # 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 [tcl::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 expand_right 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 -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] - #puts stderr "--> [ansistring VIEW -lf 1 -nul 1 $rinfo] <--" - 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 [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] - } - - variable optimise_ptruns 10 ;# can be set to zero to disable the ptruns branches - - # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### - # 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? - # This would probably be impractical to support for different fonts) - #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. - - #puts stderr "renderline '$args'" - variable optimise_ptruns - - if {[llength $args] < 2} { - error {usage: ?-info 0|1? ?-startcolumn ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-expand_right [1|0]? undertext overtext} - } - set under [lindex $args end-1] - set over [lindex $args end] - #lassign [lrange $args end-1 end] under over - if {[string last \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" - #} - - #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\ - -expand_right 0\ - -transparent 0\ - -startcolumn 1\ - -cursor_column 1\ - -cursor_row ""\ - -insert_mode 1\ - -crm_mode 0\ - -autowrap_mode 1\ - -reverse_mode 0\ - -info 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -cursor_restore_attributes ""\ - -cp437 0\ - -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, currsor movements to 2nd charcol, or overflow/expand_right - #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] - tcl::dict::for {k v} $argsflags { - switch -- $k { - -experimental - -cp437 - -width - -expand_right - -transparent - -startcolumn - -cursor_column - -cursor_row - - -crm_mode - -insert_mode - -autowrap_mode - -reverse_mode - - -info - -exposed1 - -exposed2 - -cursor_restore_attributes { - tcl::dict::set opts $k $v - } - default { - error "overtype::renderline unknown option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_width [tcl::dict::get $opts -width] - set opt_etabs [tcl::dict::get $opts -etabs] - set opt_expand_right [tcl::dict::get $opts -expand_right] - 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 {![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 [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 [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 opt_crm_mode [tcl::dict::get $opts -crm_mode];# CRM - show control character mode - # -- --- --- --- --- --- --- --- --- --- --- --- - set temp_cursor_saved [tcl::dict::get $opts -cursor_restore_attributes] - - set cp437_glyphs [tcl::dict::get $opts -cp437] - 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? - tcl::dict::unset cp437_map \n - } - - set opt_transparent [tcl::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 [tcl::dict::get $opts -info] - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_exposed1 [tcl::dict::get $opts -exposed1] - set opt_exposed2 [tcl::dict::get $opts -exposed2] - # -- --- --- --- --- --- --- --- --- --- --- --- - - if {$opt_row_context eq ""} { - set cursor_row 1 - } else { - set cursor_row $opt_row_context - } - - set insert_mode $opt_insert_mode ;#default 1 - set autowrap_mode $opt_autowrap_mode ;#default 1 - set crm_mode $opt_crm_mode ;#default 0 (Show Control Character mode) - set reverse_mode $opt_reverse_mode - - #----- - # - 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 - } - - 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 ""} { - 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] - } - set understacks [list] - set understacks_gx [list] - set pm_list [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 expand_right 0 truncation - set remainder [list] ;#for returnextra - foreach {pt code} $undermap { - #pt = plain text - #append pt_underchars $pt - if {$pt ne ""} { - if {$cp437_glyphs} { - set pt [tcl::string::map $cp437_map $pt] - } - set is_ptrun 0 - if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { - set p1 [tcl::string::index $pt 0] - set hex [format %x [scan $p1 %c]] ;#punk::char::char_hex - set re [tcl::string::cat {^[} \\U$hex {]+$}] - set is_ptrun [regexp $re $pt] - } - if {$is_ptrun} { - #switch -- $p1 { - # " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - - # 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 {$p1 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 $p1] ;# when zero??? - # } - # } - #} - set width [grapheme_width_cached $p1] ;# when zero??? - set ptlen [string length $pt] - if {$width <= 1} { - #review - 0 and 1? - incr i_u $ptlen - lappend understacks {*}[lrepeat $ptlen $u_codestack] - lappend understacks_gx {*}[lrepeat $ptlen $u_gx_stack] - lappend undercols {*}[lrepeat $ptlen $p1] - } else { - incr i_u $ptlen ;#2nd col empty str - so same as above - set 2ptlen [expr {$ptlen * 2}] - lappend understacks {*}[lrepeat $2ptlen $u_codestack] - lappend understacks_gx {*}[lrepeat $2ptlen $u_gx_stack] - set l [concat {*}[lrepeat $ptlen [list $p1 ""]] - lappend undercols {*}$l - unset l - } - - } else { - foreach grapheme [punk::char::grapheme_split $pt] { - #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 - - 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 { - #zero width still acts as 1 below??? review what should happen - 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] ;#can only use with graphemes that have a single replacement char.. - 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 - #keep any remaining PMs in place - if {$code ne ""} { - set c1c2 [tcl::string::range $code 0 1] - - set leadernorm [tcl::string::range [tcl::string::map [list\ - \x1b\[ 7CSI\ - \x9b 8CSI\ - \x1b\( 7GFX\ - \x1b^ 7PMX\ - \x1bX 7SOS\ - ] $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 {[tcl::string::index $c1c2 0] eq "\x1b"} { - set maybemouse [tcl::string::index $code 2] - } - - 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]} { - 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 -- [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 - } - B { - set u_gx_stack [list] - } - } - } - 7PMX - 7SOS { - #we can have PMs or SOS (start of string) in the underlay - though mostly the PMs should have been processed.. - #attach the PM/SOS (entire ANSI sequence) to the previous grapheme! - #It should not affect the size - but terminal display may get thrown out if terminal doesn't support them. - - #note that there may in theory already be ANSI stored - we don't assume it was a pure grapheme string - set graphemeplus [lindex $undercols end] - if {$graphemeplus ne "\0"} { - append graphemeplus $code - } else { - set graphemeplus $code - } - lset undercols end $graphemeplus - #The grapheme_width_cached function will be called on this later - and doesn't account for ansi. - #we need to manually cache the item with it's proper width - variable grapheme_widths - #stripped and plus version keys pointing to same length - dict set grapheme_widths $graphemeplus [grapheme_width_cached [::punk::ansi::ansistrip $graphemeplus]] - - } - 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..? - } - - #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} { - #set undercols [list {*}$undercols {*}[lrepeat $diff "\u0000"]] ;#2024 - much slower - lappend undercols {*}[lrepeat $diff "\u0000"] - lappend understacks {*}[lrepeat $diff $cs] - lappend understacks_gx {*}[lrepeat $diff $gs] - } - } - } - - if {$opt_width ne "\uFFEF"} { - set renderwidth $opt_width - } else { - set renderwidth [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 containing the right number of columns. - #this will be processed as transparent - and handle doublewidth underlay characters appropriately - set startpadding [string repeat " " [expr {$opt_colstart -1}]] - #overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency - if {$startpadding ne "" || $overdata ne ""} { - if {[punk::ansi::ta::detect $overdata]} { - set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata] - } else { - #single plaintext part - set overmap [list $startpadding$overdata] - } - } else { - set overmap [list] - } - #### - - - #todo - detect plain ascii no-ansi input line (aside from leading ansi reset) - #will that allow some optimisations? - - #todo - detect repeated transparent char in overlay - #regexp {^(.)\1+$} ;#backtracking regexp - relatively slow. - # - try set c [string index $data 0]; regexp [string map [list %c% $c] {^[%c%]+$}] $data - #we should be able to optimize to pass through the underlay?? - - #??? - 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 {$pt ne ""} { - #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 [tcl::string::map $cp437_map $pt] - } - append pt_overchars $pt - #will get empty pt between adjacent codes - if {!$crm_mode} { - - set is_ptrun 0 - if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { - set p1 [tcl::string::index $pt 0] - set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+$}] - set is_ptrun [regexp $re $pt] - - #leading only? we would have to check for graphemes at the trailing boundary? - #set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+}] - #set is_ptrun [regexp -indices $re $pt runrange] - #if {$is_ptrun && 1} { - #} - } - if {$is_ptrun} { - #review - in theory a run over a certain length won't be part of some grapheme combo (graphemes can be long e.g 44?, but not as runs(?)) - #could be edge cases for runs at line end? (should be ok as we include trailing \n in our data) - set len [string length $pt] - set g_element [list g $p1] - - #lappend overstacks {*}[lrepeat $len $o_codestack] - #lappend overstacks_gx {*}[lrepeat $len $o_gxstack] - #incr i_o $len - #lappend overlay_grapheme_control_list {*}[lrepeat $len [list g $p1]] - #lappend overlay_grapheme_control_stacks {*}[lrepeat $len $o_codestack] - - set pi 0 - incr i_o $len - while {$pi < $len} { - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - lappend overlay_grapheme_control_list $g_element - lappend overlay_grapheme_control_stacks $o_codestack - incr pi - } - } else { - 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 - } - } - } else { - set tsbegin [clock micros] - foreach grapheme_original [punk::char::grapheme_split $pt] { - set pt_crm [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $grapheme_original] - #puts stderr "ptlen [string length $pt] graphemelen[string length $grapheme_original] pt_crmlen[string length $pt_crm] $pt_crm" - foreach grapheme [punk::char::grapheme_split $pt_crm] { - if {$grapheme eq "\n"} { - lappend overlay_grapheme_control_stacks $o_codestack - lappend overlay_grapheme_control_list [list crmcontrol "\x1b\[00001E"] - } else { - 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 - } - } - } - set elapsed [expr {[clock micros] - $tsbegin}] - puts stderr "ptlen [string length $pt] elapsedus:$elapsed" - } - } - - #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 ""} { - #we need to immediately set crm_mode here if \x1b\[3h received - if {$code eq "\x1b\[3h"} { - set crm_mode 1 - } elseif {$code eq "\x1b\[3l"} { - set crm_mode 0 - } - #else crm_mode could be set either way from options - if {$crm_mode && $code ne "\x1b\[00001E"} { - #treat the code as type 'g' like above - only allow through codes to reset mode REVIEW for now just \x1b\[3l ? - #we need to somehow convert further \n in the graphical rep to an instruction for newline that will bypass further crm_mode processing or we would loop. - set code_as_pt [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $code] - #split using standard split for first foreach loop - grapheme based split when processing 2nd foreach loop - set chars [split $code_as_pt ""] - set codeparts [list] ;#list of 2-el lists each element {crmcontrol } or {g } - foreach c $chars { - if {$c eq "\n"} { - #use CNL (cursor next line) \x1b\[00001E ;#leading zeroes ok for this processor - used as debugging aid to distinguish - lappend codeparts [list crmcontrol "\x1b\[00001E"] - } else { - if {[llength $codeparts] > 0 && [lindex $codeparts end 0] eq "g"} { - set existing [lindex $codeparts end 1] - lset codeparts end [list g [string cat $existing $c]] - } else { - lappend codeparts [list g $c] - } - } - } - - set partidx 0 - foreach record $codeparts { - lassign $record rtype rval - switch -exact -- $rtype { - g { - append pt_overchars $rval - foreach grapheme [punk::char::grapheme_split $rval] { - 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 - } - } - crmcontrol { - #leave o_codestack - lappend overlay_grapheme_control_stacks $o_codestack - lappend overlay_grapheme_control_list [list crmcontrol $rval] - } - } - } - } else { - 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 { - #review - 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 {[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 "" - #} - # -- --- --- --- --- --- --- --- - - - #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_expand_right} { - #expand_right 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. - #we currently only support horizontal expansion to the right (review regarding RTL text!) - set overflow_idx -1 - } else { - #expand_right 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 -expand_right 1 "" data - - #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" - 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 - #crm_mode affects both graphic and control - if {0 && $crm_mode} { - set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $ch] - set chars [string map [list \n "\x1b\[00001E"] $chars] - if {[llength [split $chars ""]] > 1} { - priv::render_unapplied $overlay_grapheme_control_list $gci - #prefix the unapplied controls with the string version of this control - set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] - set unapplied [join $unapplied_list ""] - #incr idx_over - break - } else { - set ch $chars - } - } - 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 <= $renderwidth-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 [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 { - "" { - 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 expand_right = 1 - 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" - if {$insert_mode == 0} { - incr cursor_row - if {$idx == -1 || $overflow_idx > $idx} { - #don't set overflow_idx higher if it's already set lower and we're adding graphemes to overflow - set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 - } - set instruction lf_mid - priv::render_unapplied $overlay_grapheme_control_list $gci - break - } else { - incr cursor_row - #don't adjust the overflow_idx - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction lf_mid - break ;# could have overdata following the \n - don't keep processing - } - } - - } - "" { - #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 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} { - #REVIEW - set next_gc [lindex $overlay_grapheme_control_list $gci+1] ;#next grapheme or control - lassign $next_gc next_type next_item - if {$autowrap_mode || $next_type ne "g"} { - 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 { - #no point throwing back to caller for each grapheme that is overflowing - #without this branch - renderline would be called with overtext reducing only by one grapheme per call - #processing a potentially long overtext each time (ie - very slow) - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #JMN4 - - } - } - } else { - #review. - #overflow_idx = -1 - #This corresponds to expand_right 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 " " - #tcl::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] - #JMN - 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 [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 - 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 [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 - } - } - } 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} { - 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 - } - } - } - } ;# end switch - - - } - other - crmcontrol { - if {$crm_mode && $type ne "crmcontrol" && $item ne "\x1b\[00001E"} { - if {$item eq "\x1b\[3l"} { - set crm_mode 0 - } else { - #When our initial overlay split was done - we weren't in crm_mode - so there are codes that weren't mapped to unicode control character representations - #set within_undercols [expr {$idx <= $renderwidth-1}] - #set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $item] - set chars [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $item] - priv::render_unapplied $overlay_grapheme_control_list $gci - #prefix the unapplied controls with the string version of this control - set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] - set unapplied [join $unapplied_list ""] - - break - } - } - - #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 possibly 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' - - - #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? - - 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)} - #tcl 8.7 - faster to use inline list than to store it in a local var outside of loop. - #(somewhat surprising) - set leadernorm [tcl::string::range [tcl::string::map [list\ - \x1b\[< 1006\ - \x1b\[ 7CSI\ - \x1bY 7MAP\ - \x1bP 7DCS\ - \x90 8DCS\ - \x9b 8CSI\ - \x1b\] 7OSC\ - \x9d 8OSC\ - \x1b 7ESC\ - ] $c1c2c3] 0 3] ;#leadernorm is 1st 1,2 or 3 chars mapped to 4char normalised indicator - or is original first chars (1,2 or 3 len) - - #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 [tcl::string::cat $leadernorm [tcl::string::range $code 3 end]] - } - 7CSI - 7OSC { - #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] - set codenorm $leadernorm[tcl::string::range $code 2 end] - } - 7DCS { - #ESC P - #Device Control String https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h4-Controls-beginning-with-ESC:ESC-F.C74 - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] - } - 8DCS { - #8-bit Device Control String - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] - } - 7MAP { - #map to another type of code to share implementation branch - set codenorm $leadernorm[tcl::string::range $code 1 end] - } - 7ESC { - #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] - set codenorm $leadernorm[tcl::string::range $code 1 end] - } - 8CSI - 8OSC { - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] - } - default { - puts stderr "Sequence detected as ANSI, but not handled in leadernorm switch. code: [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - #we haven't made a mapping for this - #could in theory be 1,2 or 3 in len - #although we shouldn't be getting here if the regexp for ansi codes is kept in sync with our switch branches - set codenorm $code - } - } - - switch -- $leadernorm { - 7MAP { - switch -- [lindex $codenorm 4] { - Y { - #vt52 movement. we expect 2 chars representing position (limited range) - set params [tcl::string::range $codenorm 5 end] - if {[tcl::string::length $params] != 2} { - #shouldn't really get here or need this branch if ansi splitting was done correctly - puts stderr "overtype::renderline ESC Y recognised as vt52 move, but incorrect parameters length ([string length $params] vs expected 2) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]" - } - set line [tcl::string::index $params 5] - set column [tcl::string::index $params 1] - set r [expr {[scan $line %c] -31}] - set c [expr {[scan $column %c] -31}] - - #MAP to: - #CSI n;m H - CUP - Cursor Position - set leadernorm 7CSI - set codenorm "$leadernorm${r}\;${c}H" - } - } - } - } - - #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 -- [tcl::string::index $codenorm end] { - M { - puts stderr "mousedown $codenorm" - } - m { - puts stderr "mouseup $codenorm" - } - } - - } - {7CSI} - {8CSI} { - set param [tcl::string::range $codenorm 4 end-1] - #puts stdout "--> CSI [tcl::string::index $leadernorm 0] bit param:$param" - set code_end [tcl::string::index $codenorm end] ;#used for e.g h|l set/unset mode - - switch -exact -- $code_end { - A { - #Row move - up - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #todo - lassign [split $param {;}] num modifierkey - if {$modifierkey ne ""} { - puts stderr "modifierkey:$modifierkey" - } - - 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 { - #CUD - Cursor Down - #Row move - down - lassign [split $param {;}] num modifierkey - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #move down - if {$modifierkey ne ""} { - puts stderr "modifierkey:$modifierkey" - } - 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 - } - C { - #CUF - Cursor Forward - #Col move - #puts stdout "->forward" - #todo - consider right-to-left cursor mode (e.g Hebrew).. some day. - #cursor forward - #right-arrow/move forward - lassign [split $param {;}] num modifierkey - if {$modifierkey ne ""} { - puts stderr "modifierkey:$modifierkey" - } - 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 {$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_right and 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 { - #review - dead branch - if {!$expand_right || ($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 {[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] - #} - 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 [tcl::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}] - } - } - } - } - } - D { - #Col move - #puts stdout "<-back" - #cursor back - #left-arrow/move-back when ltr mode - lassign [split $param {;}] num modifierkey - if {$modifierkey ne ""} { - puts stderr "modifierkey:$modifierkey" - } - 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 - } - } - } - E { - #CNL - Cursor Next Line - if {$param eq ""} { - set downmove 1 - } else { - set downmove [expr {$param}] - } - puts stderr "renderline CNL down-by-$downmove" - set cursor_column 1 - set cursor_row [expr {$cursor_row + $downmove}] - set idx [expr {$cursor_column -1}] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move - break - - } - F { - #CPL - Cursor Previous Line - if {$param eq ""} { - set upmove 1 - } else { - set upmove [expr {$param}] - } - puts stderr "renderline CPL up-by-$upmove" - set cursor_column 1 - set cursor_row [expr {$cursor_row -$upmove}] - if {$cursor_row < 1} { - set cursor_row 1 - } - set idx [expr {$cursor_column - 1}] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move - break - - } - G { - #CHA - Cursor Horizontal Absolute (move to absolute column no) - if {$param eq ""} { - set targetcol 1 - } else { - set targetcol $param - if {![string is integer -strict $targetcol]} { - puts stderr "renderline CHA (Cursor Horizontal Absolute) error. Unrecognised parameter '$param'" - } - set targetcol [expr {$param}] - set max [llength $outcols] - if {$overflow_idx == -1} { - incr max - } - if {$targetcol > $max} { - puts stderr "renderline CHA (Cursor Horizontal Absolute) error. Param '$param' > max: $max" - set targetcol $max - } - } - #adjust to colstart - as column 1 is within overlay - #??? REVIEW - set idx [expr {($targetcol -1) + $opt_colstart -1}] - - - set cursor_column $targetcol - #puts stderr "renderline absolute col move ESC G (TEST)" - } - H - f { - #CSI n;m H - CUP - Cursor Position - - #CSI n;m f - HVP - Horizontal Vertical Position REVIEW - same as CUP with differences (what?) in some terminal modes - # - 'counts as effector format function (like CR or LF) rather than an editor function (like CUD or CNL)' - # - REVIEW - #see Annex A at: https://www.ecma-international.org/wp-content/uploads/ECMA-48_5th_edition_june_1991.pdf - - #test e.g ansicat face_2.ans - #$re_both_move - lassign [split $param {;}] paramrow paramcol - #missing defaults to 1 - #CSI ;5H = CSI 1;5H -> row 1 col 5 - #CSI 17;H = CSI 17H = CSI 17;1H -> row 17 col 1 - - if {$paramcol eq ""} {set paramcol 1} - if {$paramrow eq ""} {set paramrow 1} - if {![string is integer -strict $paramcol] || ![string is integer -strict $paramrow]} { - puts stderr "renderline CUP (CSI H) unrecognised param $param" - #ignore? - } else { - set max [llength $outcols] - if {$overflow_idx == -1} { - incr max - } - if {$paramcol > $max} { - set target_column $max - } else { - set target_column [expr {$paramcol}] - } - - - if {$paramrow < 1} { - puts stderr "renderline CUP (CSI H) bad row target 0. Assuming 1" - set target_row 1 - } else { - set target_row [expr {$paramrow}] - } - if {$target_row == $cursor_row} { - #col move only - no need for break and move - #puts stderr "renderline CUP col move only to col $target_column param:$param" - set cursor_column $target_column - set idx [expr {$cursor_column -1}] - } else { - set cursor_row $target_row - set cursor_column $target_column - set idx [expr {$cursor_column -1}] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move - break - } - } - } - J { - set modegroup [tcl::string::index $codenorm 4] ;#e.g ? - switch -exact -- $modegroup { - ? { - #CSI ? Pn J - selective erase - puts stderr "overtype::renderline ED - SELECTIVE ERASE IN DISPLAY (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - default { - puts stderr "overtype::renderline ED - ERASE IN DISPLAY (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - if {$param eq ""} {set param 0} - switch -exact -- $param { - 0 { - #clear from cursor to end of screen - } - 1 { - #clear from cursor to beginning of screen - } - 2 { - #clear entire screen - #ansi.sys - move cursor to upper left REVIEW - set cursor_row 1 - set cursor_column 1 - set idx [expr {$cursor_column -1}] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr idx_over - if {[llength $outcols]} { - priv::render_erasechar 0 [llength $outcols] - } - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction clear_and_move - break - } - 3 { - #clear entire screen. presumably cursor doesn't move - otherwise it would be same as 2J ? - - } - default { - } - } - - } - } - } - K { - #see DECECM regarding background colour - set modegroup [tcl::string::index $codenorm 4] ;#e.g ? - switch -exact -- $modegroup { - ? { - puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - set param [string range $param 1 end] ;#chop qmark - if {$param eq ""} {set param 0} - switch -exact -- $param { - 0 { - #clear from cursor to end of line - depending on DECSCA - } - 1 { - #clear from cursor to beginning of line - depending on DECSCA - - } - 2 { - #clear entire line - depending on DECSCA - } - default { - puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - - } - default { - puts stderr "overtype::renderline EL - ERASE IN LINE (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - if {$param eq ""} {set param 0} - switch -exact -- $param { - 0 { - #clear from cursor to end of line - } - 1 { - #clear from cursor to beginning of line - - } - 2 { - #clear entire line - } - default { - puts stderr "overtype::renderline EL - ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - } - } - } - L { - puts stderr "overtype::renderline IL - Insert Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - M { - #CSI Pn M - DL - Delete Line - puts stderr "overtype::renderline DL - Delete Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - - } - T { - #CSI Pn T - SD Pan Up (empty lines introduced at top) - #CSI Pn+T - kitty extension (lines at top come from scrollback buffer) - #Pn new lines appear at top of the display, Pn old lines disappear at the bottom of the display - if {$param eq "" || $param eq "0"} {set param 1} - if {[string index $param end] eq "+"} { - puts stderr "overtype::renderline CSI Pn + T - kitty Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } else { - puts stderr "overtype::renderline CSI Pn T - SD Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - X { - puts stderr "overtype::renderline X ECH ERASE CHARACTER - $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. - } - q { - set code_secondlast [tcl::string::index $codenorm end-1] - switch -exact -- $code_secondlast { - {"} { - #DECSCA - Select Character Protection Attribute - #(for use with selective erase: DECSED and DECSEL) - set param [tcl::string::range $codenorm 4 end-2] - if {$param eq ""} {set param 0} - #TODO - store like SGR in stacks - replays? - switch -exact -- $param { - 0 - 2 { - #canerase - puts stderr "overtype::renderline - DECSCA canerase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - 1 { - #cannoterase - puts stderr "overtype::renderline - DECSCA cannoterase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - default { - puts stderr "overtype::renderline DECSCA param '$param' not understood [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - - } - default { - puts stderr "overtype::renderline - CSI ... q not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - - } - 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 { - #code conflict between ansi emulation and DECSLRM - REVIEW - #ANSISYSSC (when no parameters) - like other terminals - essentially treat same as DECSC - # todo - when parameters - support DECSLRM instead - - if {$param ne ""} { - #DECSLRM - should only be recognised if DECLRMM is set (vertical split screen mode) - lassign [split $param {;} margin_left margin_right - puts stderr "overtype DECSLRM not yet supported - got [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - if {$margin_left eq ""} { - set margin_left 1 - } - set columns_per_page 80 ;#todo - set to 'page width (DECSCPP set columns per page)' - could be 132 or?? - if {$margin_right eq ""} { - set margin_right $columns_per_page - } - puts stderr "DECSLRM margin left: $margin_left margin right: $margin_right" - if {![string is integer -strict $margin_left] || $margin_left < 0} { - puts stderr "DECSLRM invalid margin_left" - } - if {![string is integer -strict $margin_right] || $margin_right < 0} { - puts stderr "DECSLRM invalid margin_right" - } - set scrolling_region_size [expr {$margin_right - $margin_left}] - if {$scrolling_region_size < 2 || $scrolling_region_size > $columns_per_page} { - puts stderr "DECSLRM region size '$scrolling_regsion_size' must be between 1 and $columns_per_page" - } - #todo - - - } else { - #DECSC - #//notes on expected behaviour: - #DECSC - saves following items in terminal's memory - #cursor position - #character attributes set by the SGR command - #character sets (G0,G1,G2 or G3) currently in GL and GR - #Wrap flag (autowrap or no autowrap) - #State of origin mode (DECOM) - #selective erase attribute - #any single shift 2 (SS2) or single shift 3(SSD) functions sent - - #$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 { - #ANSISYSRC save cursor (when no parameters) (DECSC) - - #$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 - } - "{" { - - puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" - } - "}" { - set code_secondlast [tcl::string::index $codenorm end-1] - switch -exact -- $code_secondlast { - ' { - puts stderr "renderline warning - DECIC - Insert Column - CSI...' - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" - } - default { - puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" - } - } - } - ~ { - set code_secondlast [tcl::string::index $codenorm end-1] ;#used for e.g CSI x '~ - switch -exact -- $code_secondlast { - ' { - #DECDC - editing sequence - Delete Column - puts stderr "renderline warning - DECDC - unimplemented" - } - default { - #$re_vt_sequence - 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 { - #set mode unset mode - #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 - set modegroup [tcl::string::index $codenorm 4] ;#e.g ? = - switch -exact -- $modegroup { - ? { - set smparams [tcl::string::range $codenorm 5 end-1] ;#params between ? and h|l - #one or more modes can be set - set smparam_list [split $smparams {;}] - foreach num $smparam_list { - switch -- $num { - "" { - #ignore empties e.g extra/trailing semicolon in params - } - 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 - - if {$code_end eq "h"} { - #set (enable) - set reverse_mode 1 - } else { - #reset (disable) - set reverse_mode 0 - } - - } - 7 { - #DECAWM autowrap - if {$code_end 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 usually - but sanity check with warning for now. - if {$idx >= $overflow_idx} { - puts stderr "renderline warning - idx '$idx' >= overflow_idx '$overflow_idx' - unexpected" - } - } else { - #reset (disable) - set autowrap_mode 0 - #REVIEW! - set overflow_idx -1 - } - } - 25 { - if {$code_end eq "h"} { - #visible cursor - - } else { - #invisible cursor - - } - } - 117 { - #DECECM - Erase Color Mode - #https://invisible-island.net/ncurses/ncurses.faq.html - #The Erase color selection controls the background color used when text is erased or new - #text is scrolled on to the screen. Screen background causes newly erased areas or - #scrolled text to be written using color index zero, the screen background. This is VT - #and DECterm compatible. Text background causes erased areas or scrolled text to be - #written using the current text background color. This is PC console compatible and is - #the factory default. - - #see also: https://unix.stackexchange.com/questions/251726/clear-to-end-of-line-uses-the-wrong-background-color-in-screen - } - } - } - } - = { - set num [tcl::string::range $codenorm 5 end-1] ;#param between = and h|l - puts stderr "overtype::renderline CSI=...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - default { - #e.g CSI 4 h - set num [tcl::string::range $codenorm 4 end-1] ;#param before h|l - switch -exact -- $num { - 3 { - puts stderr "CRM MODE $code_end" - #CRM - Show control character mode - # 'No control functions are executed except LF,FF and VT which are represented in the CRM FONT before a CRLF(new line) is executed' - # - #use ansistring VIEW -nul 1 -lf 2 -ff 2 -vt 2 - #https://vt100.net/docs/vt510-rm/CRM.html - #NOTE - vt100 CRM always does auto-wrap at right margin. - #disabling auto-wrap in set-up or by sequence is disabled. - #We should default to turning off auto-wrap when crm_mode enabled.. but - #displaying truncated (on rhs) crm can still be very useful - and we have optimisation in overflow to avoid excess renderline calls (per grapheme) - #we therefore could reasonably put in an exception to allow auto_wrap to be disabled after crm_mode is engaged, - #although this would be potentially an annoying difference to some.. REVIEW - if {$code_end eq "h"} { - set crm_mode 1 - 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 - } - } else { - set crm_mode 0 - } - } - 4 { - #IRM - Insert/Replace Mode - if {$code_end eq "h"} { - #CSI 4 h - set insert_mode 1 - } else { - #CSI 4 l - #replace mode - set insert_mode 0 - } - } - default { - puts stderr "overtype::renderline CSI...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - } - } - } - } - | { - switch -- [tcl::string::index $codenorm end-1] { - {$} { - #CSI ... $ | DECSCPP set columns per page- (recommended in vt510 docs as preferable to DECCOLM) - #real terminals generally only supported 80/132 - #some other virtuals support any where from 2 to 65,536? - #we will allow arbitrary widths >= 2 .. to some as yet undetermined limit. - #CSI $ | - #empty or 0 param is 80 for compatibility - other numbers > 2 accepted - set page_width -1 ;#flag as unset - if {$param eq ""} { - set page_width 80 - } elseif {[string is integer -strict $param] && $param >=2 0} { - set page_width [expr {$param}] ;#we should allow leading zeros in the number - but lets normalize using expr - } else { - puts stderr "overtype::renderline unacceptable DECSPP value '$param'" - } - - if {$page_width > 2} { - puts stderr "overtype::renderline DECSCPP - not implemented - but selected width '$page_width' looks ok" - #if cursor already beyond new page_width - will move to right colum - otherwise no cursor movement - - } - - } - default { - puts stderr "overtype::renderline unrecognised CSI code ending in pipe (|) [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 {\x1b(D|M|E)$} - #also vt52 Y.. - #also PM \x1b^...(ST) - switch -- [tcl::string::index $codenorm 4] { - c { - #RIS - reset terminal to initial state - where 'terminal' in this case is the renderspace - not the underlying terminal! - puts stderr "renderline reset" - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction reset - break - } - 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 "renderline ESC D not fully implemented" - incr cursor_row - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction 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 "overtype::renderline ESC E unimplemented" - - } - H { - #\x88 - #Tab Set - puts stderr "overtype::renderline ESC H tab set unimplemented" - } - 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 "overtype::renderline 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 - } - N { - #\x8e - affects next character only - puts stderr "overtype::renderline single shift select G2 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - O { - #\x8f - affects next character only - puts stderr "overtype::renderline single shift select G3 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - P { - #\x90 - #DCS - shouldn't get here - handled in 7DCS branch - #similarly \] OSC (\x9d) and \\ (\x9c) ST - } - V { - #\x96 - - } - W { - #\x97 - } - X { - #\x98 - #SOS - if {[string index $code end] eq "\007"} { - set sos_content [string range $code 2 end-1] ;#ST is \007 - } else { - set sos_content [string range $code 2 end-2] ;#ST is \x1b\\ - } - #return in some useful form to the caller - #TODO! - lappend sos_list [list string $sos_content row $cursor_row column $cursor_column] - puts stderr "overtype::renderline ESCX SOS UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - ^ { - #puts stderr "renderline PM" - #Privacy Message. - if {[string index $code end] eq "\007"} { - set pm_content [string range $code 2 end-1] ;#ST is \007 - } else { - set pm_content [string range $code 2 end-2] ;#ST is \x1b\\ - } - #We don't want to render it - but we need to make it available to the application - #see the textblock library in punk, for the exception we make here for single backspace. - #It is unlikely to be encountered as a useful PM - so we hack to pass it through as a fix - #for spacing issues on old terminals which miscalculate the single-width 'Symbols for Legacy Computing' - if {$pm_content eq "\b"} { - #puts stderr "renderline PM sole backspace special handling for \U1FB00 - \U1FBFF" - #esc^\b\007 or esc^\besc\\ - #HACKY pass-through - targeting terminals that both mis-space legacy symbols *and* don't support PMs - #The result is repair of the extra space. If the terminal is a modern one and does support PM - the \b should be hidden anyway. - #If the terminal has the space problem AND does support PMs - then this just won't fix it. - #The fix relies on the symbol-supplier to cooperate by appending esc^\b\esc\\ to the problematic symbols. - - #priv::render_addchar $idx $code [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - #idx has been incremented after last grapheme added - priv::render_append_to_char [expr {$idx -1}] $code - } - #lappend to a dict element in the result for application-specific processing - lappend pm_list $pm_content - } - _ { - #APC Application Program Command - #just warn for now.. - puts stderr "overtype::renderline ESC_ APC command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - default { - puts stderr "overtype::renderline ESC code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]" - } - } - - } - 7DCS - 8DCS { - puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - #ST (string terminator) \x9c or \x1b\\ - if {[tcl::string::index $codenorm end] eq "\x9c"} { - set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is 8-bit 0x9c - } else { - set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\ - } - - } - 7OSC - 8OSC { - # OSCs are terminated with ST of either \007 or \x1b\\ - we allow either whether code was 7 or 8 bit - if {[tcl::string::index $codenorm end] eq "\007"} { - set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is \007 - } else { - set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\ - } - set first_colon [tcl::string::first {;} $code_content] - if {$first_colon == -1} { - #there probably should always be a colon - but we'll try to make sense of it without - set osc_code $code_content ;#e.g \x1b\]104\007 vs \x1b\]104\;\007 - } else { - set osc_code [tcl::string::range $code_content 0 $first_colon-1] - } - switch -exact -- $osc_code { - 2 { - set newtitle [tcl::string::range $code_content 2 end] - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction [list set_window_title $newtitle] - break - } - 4 { - #OSC 4 - set colour palette - #can take multiple params - #e.g \x1b\]4\;1\;red\;2\;green\x1b\\ - set params [tcl::string::range $code_content 2 end] ;#strip 4 and first semicolon - set cmap [dict create] - foreach {cnum spec} [split $params {;}] { - if {$cnum >= 0 and $cnum <= 255} { - #todo - parse spec from names like 'red' to RGB - #todo - accept rgb:ab/cd/ef as well as rgb:/a/b/c (as alias for aa/bb/cc) - #also - what about rgb:abcd/defg/hijk and 12-bit abc/def/ghi ? - dict set cmap $cnum $spec - } else { - #todo - log - puts stderr "overtype::renderline OSC 4 set colour palette - bad color number: $cnum must be from 0 to 255. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - - puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - - - } - 10 - 11 - 12 - 13 - 14 - 15 - 16 - 17 { - #OSC 10 through 17 - so called 'dynamic colours' - #can take multiple params - each successive parameter changes the next colour in the list - #- e.g if code started at 11 - next param is for 12. 17 takes only one param because there are no more - #10 change text foreground colour - #11 change text background colour - #12 change text cursor colour - #13 change mouse foreground colour - #14 change mouse background colour - #15 change tektronix foreground colour - #16 change tektronix background colour - #17 change highlight colour - set params [tcl::string::range $code_content 2 end] - - puts stderr "overtype::renderline OSC $osc_code set dynamic colours unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - - - } - 18 { - #why is this not considered one of the dynamic colours above? - #https://www.xfree86.org/current/ctlseqs.html - #tektronix cursor color - puts stderr "overtype::renderline OSC 18 - set tektronix cursor color unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - 99 { - #kitty desktop notifications - #https://sw.kovidgoyal.net/kitty/desktop-notifications/ - # 99 ; metadata ; payload - puts stderr "overtype::renderline OSC 99 kitty desktop notification unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - 104 { - #reset colour palette - #we want to do it for the current rendering context only (vvt) - not just pass through to underlying vt - puts stderr "overtype::renderline OSC 104 reset colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction [list reset_colour_palette] - break - } - 1337 { - #iterm2 graphics and file transfer - puts stderr "overtype::renderline OSC 1337 iterm2 graphics/file_transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]" - } - 5113 { - puts stderr "overtype::renderline OSC 5113 kitty file transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]" - } - default { - puts stderr "overtype::renderline OSC - UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - - } - default { - } - } - - - } - 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_expand_right == 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 - } - set trailing_nulls 0 - foreach ch [lreverse $outcols] { - if {$ch eq "\u0000"} { - incr trailing_nulls - } else { - break - } - } - if {$trailing_nulls} { - set first_tail_null_posn [expr {[llength $outcols] - $trailing_nulls}] - } else { - set first_tail_null_posn -1 - } - - #puts stderr "first_tail_null_posn: $first_tail_null_posn" - #puts stderr "colview: [ansistring VIEW $outcols]" - - foreach ch $outcols { - #puts "---- [ansistring VIEW $ch]" - - set gxleader "" - if {$i < [llength $understacks_gx]} { - #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"]} { - 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 [tcl::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 {$ch eq "\u0000"} { - if {$cp437_glyphs} { - #map all nulls including at tail to space - append outstring " " - } else { - if {$trailing_nulls && $i < $first_tail_null_posn} { - append outstring " " ;#map inner nulls to space - } else { - append outstring \u0000 - } - } - } else { - append outstring $ch - } - } - incr i - } - #flower.ans good test for null handling - reverse line building - #review - presence of overflow_right doesn't indicate line's trailing nulls should remain. - #The cells could have been erased? - #if {!$cp437_glyphs} { - # #if {![ansistring length $overflow_right]} { - # # set outstring [tcl::string::trimright $outstring "\u0000"] - # #} - # set outstring [tcl::string::trimright $outstring "\u0000"] - # set outstring [tcl::string::map {\u0000 " "} $outstring] - #} - - - #REVIEW - #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 [tcl::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 [tcl::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\ - crm_mode $crm_mode\ - reverse_mode $reverse_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\ - expand_right $opt_expand_right\ - replay_codes $replay_codes\ - replay_codes_underlay $replay_codes_underlay\ - replay_codes_overlay $replay_codes_overlay\ - pm_list $pm_list\ - ] - if {$opt_returnextra == 1} { - #puts stderr "renderline: $result" - 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. - } - } - 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 { - #puts stderr "renderline returning: result $outstring instruction $instruction unapplied $unapplied overflow_right $overflow_right" - return $outstring - } - #return [join $out ""] - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace overtype ---}] -} - -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} - } - 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 [tcl::dict::create\ - -transparent 1\ - -exposed 1 " "\ - -exposed 2 " "\ - ] - 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. -# -tcl::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 primarily for single grapheme - but will work for multiple -#WARNING: query CAN contain ansi or newlines - but if cache was not already set manually,the answer will be incorrect! -#We deliberately allow this for PM/SOS attached within a column -#(a cache of ansifreestring_width calls - as these are quite regex heavy) -proc overtype::grapheme_width_cached {ch} { - variable grapheme_widths - if {[tcl::dict::exists $grapheme_widths $ch]} { - return [tcl::dict::get $grapheme_widths $ch] - } - set width [punk::char::ansifreestring_width $ch] - tcl::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 [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 {[tcl::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] - } - #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::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 - 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 [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 -} - -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 {[tcl::dict::exists $cache_is_sgr $code]} { - return [tcl::dict::get $cache_is_sgr $code] - } - set answer [punk::ansi::codetype::is_sgr $code] - tcl::dict::set cache_is_sgr $code $answer - return $answer - } - # better named render_to_unapplied? - 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] - } elseif {$i == 0 || $i == $nxt} { - #nothing to do - } else { - puts stderr "render_delchar - attempt to delchar at index $i >= number of outcols $nxt - shouldn't happen" - } - } - proc render_erasechar {i count} { - upvar outcols o - upvar understacks ustacks - upvar understacks_gx gxstacks - upvar replay_codes_overlay replay - #ECH clears character attributes from erased character positions - #ECH accepts 0 or empty parameter, which is equivalent to 1. Caller of render_erasechar should do that mapping and only supply 1 or greater. - if {![tcl::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? - #DECECM ??? - set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list $replay]]] - set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]] ;# ??? review - return - } - proc render_setchar {i c } { - upvar outcols o - lset o $i $c - } - - #Initial usecase is for old-terminal hack to add PM-wrapped \b - #review - can be used for other multibyte sequences that occupy one column? - #combiners? diacritics? - proc render_append_to_char {i c} { - upvar outcols o - if {$i > [llength $o]-1} { - error "render_append_to_char cannot append [ansistring VIEW -lf 1 -nul 1 $c] to existing char at index $i while $i >= llength outcols [llength $o]" - } - set existing [lindex $o $i] - if {$existing eq "\0"} { - lset o $i $c - } else { - lset o $i $existing$c - } - } - #is actually addgrapheme? - proc render_addchar {i c sgrstack gx0stack {insert_mode 0}} { - upvar outcols o - upvar understacks ustacks - upvar understacks_gx gxstacks - - # -- --- --- - #this is somewhat of a hack.. probably not really the equivalent of proper reverse video? review - #we should ideally be able to reverse the video of a sequence that already includes SGR reverse/noreverse attributes - upvar reverse_mode do_reverse - #if {$do_reverse} { - # lappend sgrstack [a+ reverse] - #} else { - # lappend sgrstack [a+ noreverse] - #} - - #JMN3 - if {$do_reverse} { - #note we can't just look for \x1b\[7m or \x1b\[27m - # it may be a more complex sequence like \x1b\[0\;\;7\;31m etc - - set existing_reverse_state 0 - set codeinfo [punk::ansi::codetype::sgr_merge $sgrstack -info 1] - set codestate_reverse [dict get $codeinfo codestate reverse] - switch -- $codestate_reverse { - 7 { - set existing_reverse_state 1 - } - 27 { - set existing_reverse_state 0 - } - "" { - } - } - if {$existing_reverse_state == 0} { - set rflip [a+ reverse] - } else { - #reverse of reverse - set rflip [a+ noreverse] - } - #note that mergeresult can have multiple esc (due to unmergeables or non sgr codes) - set sgrstack [list [dict get $codeinfo mergeresult] $rflip] - #set sgrstack [punk::ansi::codetype::sgr_merge [list [dict get $codeinfo mergeresult] $rflip]] - } - - # -- --- --- - - 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 - } - } - } - -} - - - -# -- --- --- --- --- --- --- --- --- --- --- -tcl::namespace::eval overtype { - interp alias {} ::overtype::center {} ::overtype::centre -} - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide overtype [tcl::namespace::eval overtype { - variable version - set version 1.6.5 -}] -return - -#*** !doctools -#[manpage_end] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm index 1e09252d..6bf529eb 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm @@ -6321,7 +6321,10 @@ namespace eval punk { #useful for aliases e.g treemore -> xmore tree proc xmore {args} { if {[llength $args]} { - uplevel #0 [list {*}$args | more] + #more is older and not as featureful as less + #more importantly - at least some implementations (msys on windows) can skip output lines - unknown as to why + #uplevel #0 [list {*}$args | more] + uplevel #0 [list {*}$args | less -X] ;#-X to avoid use of alternate-screen } else { error "usage: punk::xmore args where args are run as {*}\$args | more" } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.0.tm deleted file mode 100644 index 687a6999..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.0.tm +++ /dev/null @@ -1,1630 +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) 2023 -# -# @@ Meta Begin -# Application punk::ansi 0.1.0 -# Meta platform tcl -# Meta license -# @@ Meta End - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::ansi 0 0.1.0] -#[copyright "2023"] -#[titledesc {Ansi string functions}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk Ansi library}] [comment {-- Description at end of page heading --}] -#[require punk::ansi] -#[keywords module ansi terminal console string] -#[description] -#[para]Ansi based terminal control string functions -#[para]See [package punk::ansi::console] for related functions for controlling a console - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of punk::ansi -#[para]punk::ansi functions return their values - no implicit emission to console/stdout -#[subsection Concepts] -#[para]Ansi codes can be used to control most terminals on most platforms in an 'almost' standard manner -#[para]There are many differences in terminal implementations - but most should support a core set of features -#[para]punk::ansi does not contain any code for direct terminal manipulation via the local system APIs. -#[para]Sticking to ansi codes where possible may be better for cross-platform and remote operation where such APIs are unlikely to be useable. - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::ansi -#[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] - - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval punk::ansi { - #*** !doctools - #[subsection {Namespace punk::ansi}] - #[para] Core API functions for punk::ansi - #[list_begin definitions] - - - #see also ansicolor page on wiki https://wiki.tcl-lang.org/page/ANSI+color+control - - variable test "blah\033\[1;33mETC\033\[0;mOK" - - - #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\ - {a?} {a+} a \ - ansistring\ - convert*\ - clear*\ - cursor_*\ - detect*\ - get_*\ - move*\ - reset*\ - strip*\ - test_decaln\ - titleset\ - - - 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\\ \u009c] ;#note mix of 1 and 2-byte terminals - dict set escape_terminals DCS [list \007 \033\\ \u009c] - dict set escape_terminals MISC [list \007 \033\\ \u009c] - #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? - - 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? - 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"\ - "DECPAM app keypad" "\x1b="\ - "DECPNM norm keypad" "\x1b>"\ - ] - - #control strings - #https://www.ecma-international.org/wp-content/uploads/ECMA-48_5th_edition_june_1991.pdf - # - #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) - # - - #debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway. - # "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. - #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? - proc stripansi {text} { - #*** !doctools - #[call [fun stripansi] [arg text] ] - #[para]Return a string with ansi codes stripped out - - #todo - character set selection - SS2 SS3 - how are they terminated? REVIEW - - variable escape_terminals ;#dict - variable standalone_codes ;#map to empty string - - set text [convert_g0 $text] - - - #we should just map away the 2-byte sequences too - #standalone 3 byte VT100 sequences - some of these work in wezterm - #\x1b#3 double-height letters top half - #\x1b#4 double-height letters bottom half - #\x1b#5 single-width line - #\x1b#6 double-width line - #\x1b#8 dec test fill screen - - set text [string map $standalone_codes $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 payload (review e.g title?) - - set inputlist [split $text ""] - set outputlist [list] - - 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 endseq [dict get $escape_terminals $in_escapesequence] - if {$u in $endseq} { - set in_escapesequence 0 - } elseif {$uv in $endseq} { - set in_escapesequence 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\]|\u009d)} $uv]} { - set in_escapesequence OSC - } elseif {[regexp {^(?:\033P|\u0090)} $uv]} { - set in_escapesequence DCS - } elseif {[regexp {^(?:\033X|\u0098|\033\^|\u009E|\033_|\u009F)} $uv]} { - #SOS,PM,APC - all terminated with ST - set in_escapesequence MISC - } else { - lappend outputlist $u - } - } - incr i - } - return [join $outputlist ""] - } - - #review - what happens when no terminator? - #todo - map other chars to unicode equivs - proc convert_g0 {text} { - #using not \033 inside to stop greediness - review how does it compare to ".*?" - set re {\033\(0[^\033]*\033\(B} - set re2 {\033\(0(.*)\033\(B} ;#capturing - set parts [::punk::ansi::ta::_perlish_split $re $text] - set out "" - foreach {pt g} $parts { - append out $pt - if {$g ne ""} { - #puts --$g-- - #box sample - #lqk - #x x - #mqj - #m = boxd_lur - #set map [list l \u250f k \u2513] ;#heavy - set map [list l \u250c q \u2500 k \u2510 x \u2502 m \u2514 j \u2518] ;#light - - regexp $re2 $g _match contents - append out [string map $map $contents] - } - } - return $out - } - - #todo - convert esc(0 graphics sequences to single char unicode equivalents e.g box drawing set - # esc) ?? - 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] - } - - - #CSI m = SGR (Select Graphic Rendition) - variable SGR_setting_map { - bold 1 dim 2 blink 5 fastblink 6 noblink 25 hide 8 normal 22 - underline 4 doubleunderline 21 nounderline 24 strike 9 nostrike 29 italic 3 noitalic 23 - reverse 7 noreverse 27 defaultfg 39 defaultbg 49 nohide 28 - overline 53 nooverline 55 frame 51 framecircle 52 noframe 54 - } - variable SGR_colour_map { - black 30 red 31 green 32 yellow 33 blue 34 purple 35 cyan 36 white 37 - Black 40 Red 41 Green 42 Yellow 43 Blue 44 Purple 45 Cyan 46 White 47 - BLACK 100 RED 101 GREEN 102 YELLOW 103 BLUE 104 PURPLE 105 CYAN 106 WHITE 107 - } - variable SGR_map - set SGR_map [dict merge $SGR_colour_map $SGR_setting_map] - - - proc colourmap1 {{bgname White}} { - package require textblock - - set bg [textblock::block 33 3 "[a+ $bgname] [a]"] - set colormap "" - for {set i 0} {$i <= 7} {incr i} { - append colormap "_[a+ white bold 48\;5\;$i] $i [a]" - } - set map1 [overtype::left -transparent _ $bg "\n$colormap"] - return $map1 - } - proc colourmap2 {{bgname White}} { - package require textblock - set bg [textblock::block 39 3 "[a+ $bgname] [a]"] - set colormap "" - 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 - } - set map2 [overtype::left -transparent _ $bg "\n$colormap"] - return $map2 - } - proc a? {args} { - #*** !doctools - #[call [fun a?] [opt {ansicode...}]] - #[para]Return an ansi string representing a table of codes and a panel showing the colours - variable SGR_setting_map - variable SGR_colour_map - - if {![llength $args]} { - set out "" - append out $SGR_setting_map \n - append out $SGR_colour_map \n - - try { - 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 - set bgname "White" - set map1 [colourmap1 $bgname] - set map1 [overtype::centre -transparent 1 $map1 "[a black $bgname]Standard colours[a]"] - set map2 [colourmap2 $bgname] - set map2 [overtype::centre -transparent 1 $map2 "[a black $bgname]High-intensity colours[a]"] - append out [textblock::join $map1 " " $map2] \n - #append out $map1[a] \n - #append out $map2[a] \n - - - - } on error {result options} { - puts stderr "Failed to draw colormap" - puts stderr "$result" - } finally { - return $out - } - } else { - set result [list] - set rmap [lreverse $map] - foreach i $args { - if {[string is integer -strict $i]} { - if {[dict exists $rmap $i]} { - lappend result $i [dict get $rmap $i] - } - } else { - if {[dict exists $map $i]} { - lappend result $i [dict get $map $i] - } - } - } - return $result - } - } - proc a+ {args} { - #*** !doctools - #[call [fun a+] [opt {ansicode...}]] - #[para]Returns the ansi code to apply those from the supplied list - without any reset being performed first - #[para] e.g to set foreground red and bold - #[para]punk::ansi::a red bold - #[para]to set background red - #[para]punk::ansi::a Red - #[para]see [cmd punk::ansi::a?] to display a list of codes - - #don't disable ansi here. - #we want this to be available to call even if ansi is off - variable SGR_map - set t [list] - foreach i $args { - if {[string is integer -strict $i]} { - lappend t $i - } elseif {[string first ";" $i] >=0} { - #literal with params - lappend t $i - } else { - if {[dict exists $SGR_map $i]} { - lappend t [dict get $SGR_map $i] - } else { - #accept examples for foreground - # 256f-# or 256fg-# or 256f# - # rgbf--- or rgbfg--- or rgbf-- - if {[string match -nocase "256f*" $i]} { - set cc [string trim [string range $i 4 end] -gG] - lappend t "38;5;$cc" - } elseif {[string match -nocase 256b* $i]} { - set cc [string trim [string range $i 4 end] -gG] - lappend t "48;5;$cc" - } elseif {[string match -nocase rgbf* $i]} { - set rgb [string trim [string range $i 4 end] -gG] - lassign [split $rgb -] r g b - lappend t "38;2;$r;$g;$b" - } elseif {[string match -nocase rgbb* $i]} { - set rgb [string trim [string range $i 4 end] -gG] - lassign [split $rgb -] r g b - lappend t "48;2;$r;$g;$b" - } - } - } - } - # \033 - octal. equivalently \x1b in hex which is more common in documentation - if {![llength $t]} { - return "" ;# a+ nonexistent should return nothing rather than a reset ( \033\[\;m is a reset even without explicit zero(s)) - } - return "\x1b\[[join $t {;}]m" - } - proc a {args} { - #*** !doctools - #[call [fun a] [opt {ansicode...}]] - #[para]Returns the ansi code to reset any current settings and apply those from the supplied list - #[para] by calling punk::ansi::a with no arguments - the result is a reset to plain text - #[para] e.g to set foreground red and bold - #[para]punk::ansi::a red bold - #[para]to set background red - #[para]punk::ansi::a Red - #[para]see [cmd punk::ansi::a?] to display a list of codes - - - #don't disable ansi here. - #we want this to be available to call even if ansi is off - variable SGR_map - set t [list] - foreach i $args { - if {[string is integer -strict $i]} { - lappend t $i - } elseif {[string first ";" $i] >=0} { - #literal with params - lappend t $i - } else { - if {[dict exists $SGR_map $i]} { - lappend t [dict get $SGR_map $i] - } else { - #accept examples for foreground - # 256f-# or 256fg-# or 256f# - # rgbf--- or rgbfg--- or rgbf-- - if {[string match -nocase "256f*" $i]} { - set cc [string trim [string range $i 4 end] -gG] - lappend t "38;5;$cc" - } elseif {[string match -nocase 256b* $i]} { - set cc [string trim [string range $i 4 end] -gG] - lappend t "48;5;$cc" - } elseif {[string match -nocase rgbf* $i]} { - set rgb [string trim [string range $i 4 end] -gG] - lassign [split $rgb -] r g b - lappend t "38;2;$r;$g;$b" - } elseif {[string match -nocase rgbb* $i]} { - set rgb [string trim [string range $i 4 end] -gG] - lassign [split $rgb -] r g b - lappend t "48;2;$r;$g;$b" - } - } - } - } - # \033 - octal. equivalently \x1b in hex which is more common in documentation - # empty list [a=] should do reset - same for [a= nonexistant] - # explicit reset at beginning of parameter list for a= (as opposed to a+) - set t [linsert $t 0 0] - return "\x1b\[[join $t {;}]m" - } - - - - - proc get_code_name {code} { - #*** !doctools - #[call [fun get_code_name] [arg code]] - #[para]for example - #[para] get_code_name red will return 31 - #[para] get_code_name 31 will return red - variable SGR_map - set res [list] - foreach i [split $code ";"] { - set ix [lsearch -exact $SGR_map $i] - if {[string is digit -strict $code]} { - if {$ix>-1} {lappend res [lindex $SGR_map [incr ix -1]]} - } else { - #reverse lookup code from name - if {$ix>-1} {lappend res [lindex $SGR_map [incr ix]]} - } - } - set res - } - proc reset {} { - #*** !doctools - #[call [fun reset]] - #[para]reset console - return "\x1bc" - } - proc reset_soft {} { - #*** !doctools - #[call [fun reset_soft]] - return \x1b\[!p - } - proc reset_colour {} { - #*** !doctools - #[call [fun reset_colour]] - #[para]reset colour only - return "\x1b\[0m" - } - - # -- --- --- --- --- - proc clear {} { - #*** !doctools - #[call [fun clear]] - return "\033\[2J" - } - proc clear_above {} { - #*** !doctools - #[call [fun clear_above]] - return \033\[1J - } - proc clear_below {} { - #*** !doctools - #[call [fun clear_below]] - return \033\[0J - } - - proc clear_all {} { - # - doesn't work?? - return \033\[3J - } - #see also erase_ functions - # -- --- --- --- --- - - proc cursor_on {} { - #*** !doctools - #[call [fun cursor_on]] - return "\033\[?25h" - } - proc cursor_off {} { - #*** !doctools - #[call [fun cursor_off]] - return "\033\[?25l" - } - - # -- --- --- --- --- - proc move {row col} { - #*** !doctools - #[call [fun move] [arg row] [arg col]] - #[para]Return an ansi sequence to move to row,col - #[para]aka cursor home - return \033\[${row}\;${col}H - } - proc move_emit {row col data args} { - #*** !doctools - #[call [fun move_emit] [arg row] [arg col] [arg data] [opt {row col data...}]] - #[para]Return an ansi string representing a move to row col with data appended - #[para]row col data can be repeated any number of times to return a string representing the output of the data elements at all those points - #[para]Compare to punk::console::move_emit which calls this function - but writes it to stdout - #[para]punk::console::move_emit_return will also return the cursor to the original position - #[para]There is no punk::ansi::move_emit_return because in a standard console there is no ansi string which can represent a jump back to starting position. - #[para]There is an ansi code to write the current cursor position to stdin (which will generally display on the console) - this is not quite the same thing. - #[para]punk::console::move_emit_return does it by emitting that code and starting a loop to read stdin - #[para]punk::ansi could implement a move_emit_return using the punk::console mechanism - but the resulting string would capture the cursor position at the time the string is built - which is not necessarily when the string is used. - #[para]The following example shows how to do this manually, emitting the string blah at screen position 10,10 and emitting DONE back at the line we started: - #[para][example {punk::ansi::move_emit 10 10 blah {*}[punk::console::get_cursor_pos_list] DONE}] - #[para]A string created by any move_emit_return for punk::ansi would not behave in an intuitive manner compared to other punk::ansi move functions - so is deliberately omitted. - - set out "" - if {$row eq "this"} { - append out \033\[\;${col}G$data - } else { - append out \033\[${row}\;${col}H$data - } - foreach {row col data} $args { - if {$row eq "this"} { - append out \033\[\;${col}G$data - } else { - append out \033\[${row}\;${col}H$data - } - } - return $out - } - proc move_forward {{n 1}} { - #*** !doctools - #[call [fun move_forward] [arg n]] - return \033\[${n}C - } - proc move_back {{n 1}} { - #*** !doctools - #[call [fun move_back] [arg n]] - return \033\[${n}D - } - proc move_up {{n 1}} { - #*** !doctools - #[call [fun move_up] [arg n]] - return \033\[${n}A - } - proc move_down {{n 1}} { - #*** !doctools - #[call [fun move_down] [arg n]] - return \033\[${n}B - } - proc move_column {col} { - #*** !doctools - #[call [fun move_column] [arg col]] - return \x1b\[${col}g - } - proc move_row {row} { - #*** !doctools - #[call [fun move_row] [arg row]] - return \x1b\[${row}G - } - # -- --- --- --- --- - - proc save_cursor {} { - #*** !doctools - #[call [fun save_cursor]] - return \x1b\[s - } - proc restore_cursor {} { - #*** !doctools - #[call [fun restore_cursor]] - return \x1b\[u - } - - # -- --- --- --- --- - proc erase_line {} { - #*** !doctools - #[call [fun erase_line]] - return \033\[2K - } - proc erase_sol {} { - #*** !doctools - #[call [fun erase_sol]] - #[para]Erase to start of line, leaving cursor position alone. - return \033\[1K - } - proc erase_eol {} { - #*** !doctools - #[call [fun erase_eol]] - return \033\[K - } - #see also clear_above clear_below - # -- --- --- --- --- - - proc scroll_up {n} { - #*** !doctools - #[call [fun scroll_up] [arg n]] - return \x1b\[${n}S - } - proc scroll_down {n} { - #*** !doctools - #[call [fun scroll_down] [arg n]] - return \x1b\[${n}T - } - - proc insert_spaces {count} { - #*** !doctools - #[call [fun insert_spaces] [arg count]] - return \x1b\[${count}@ - } - proc delete_characters {count} { - #*** !doctools - #[call [fun delete_characters] [arg count]] - return \x1b\[${count}P - } - proc erase_characters {count} { - #*** !doctools - #[call [fun erase_characters] [arg count]] - return \x1b\[${count}X - } - proc insert_lines {count} { - #*** !doctools - #[call [fun insert_lines] [arg count]] - return \x1b\[${count}L - } - proc delete_lines {count} { - #*** !doctools - #[call [fun delete_lines] [arg count]] - return \x1b\[${count}M - } - - proc cursor_pos {} { - #*** !doctools - #[call [fun cursor_pos]] - #[para]cursor_pos unlikely to be useful on it's own like this as when written to the terminal, this sequence causes the terminal to emit the row;col sequence to stdin - #[para]The output on screen will look something like ^[lb][lb]47;3R - #[para]Use punk::console::get_cursor_pos or punk::console::get_cursor_pos_list instead. - #[para]These functions will emit the code - but read it in from stdin so that it doesn't display, and then return the row and column as a colon-delimited string or list respectively. - #[para]The punk::ansi::cursor_pos function is used by punk::console::get_cursor_pos and punk::console::get_cursor_pos_list - return \033\[6n - } - - - #alternative to string terminator is \007 - - proc titleset {windowtitle} { - #*** !doctools - #[call [fun titleset] [arg windowtitles]] - #[para]Returns the code to set the title of the terminal window to windowtitle - #[para]This may not work on terminals which have multiple panes/windows - return "\033\]2;$windowtitle\033\\" ;#works for xterm and most derivatives - } - #titleget - https://invisible-island.net/xterm/xterm.faq.html#how2_title - #no cross-platform ansi-only mechanism ? - - proc test_decaln {} { - #Screen Alignment Test - #Reset margins, move cursor to the top left, and fill the screen with 'E' - #(doesn't work on many terminals - seems to work in FreeBSD 13.2 and wezterm on windows) - return \x1b#8 - } - - #length of text for printing characters only - #review - unicode and other non-printing chars and combining sequences? - #certain unicode chars are full-width (single char 2 columns wide) e.g see "Halfwdith and fullwidth forms" and ascii_fuillwidth blocks in punk::char::charset_names - #review - is there an existing library or better method? print to a terminal and query cursor position? - #Note this length calculation is only suitable for lines being appended to other strings if the line is pre-processed to account for backspace and carriage returns first - #If the raw line is appended to another string without such processing - the backspaces & carriage returns can affect data prior to the start of the string. - proc printing_length {line} { - if {[string first \n $line] >= 0} { - error "line_print_length must not contain newline characters" - } - #what if line has \v (vertical tab) ie more than one logical screen line? - - #review - - set line [punk::ansi::stripansi $line] - - set line [punk::char::strip_nonprinting_ascii $line] ;#only strip nonprinting after stripansi - 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 - #backspace will not move beyond a preceding newline - but we have disallowed newlines for this function already - #leading backspaces will eat into any string (even prompt in non-standard tclsh shell) that is prepended to the line - # - but for the purposes of overtype we wouldn't want that - so we strip it here in the length calculation and should strip leading backspaces in the actual data concatenation operations too. - #curiously - a backspace sequence at the end of a string also doesn't reduce the printing width - so we can also strip from RHS - - #Note that backspace following a \t will only shorten the string by one (ie it doesn't move back the whole tab width like it does interactively in the terminal) - #for this reason - it would seem best to normalize the tabs to spaces prior to performing the backspace calculation - otherwise we won't account for the 'short' tabs it effectivley produces - #normalize tabs to an appropriate* width - #*todo - handle terminal/context where tabwidth != the default 8 spaces - set line [textutil::tabify::untabify2 $line] - - set bs [format %c 0x08] - #set line [string map [list "\r${bs}" "\r"] $line] ;#backsp following a \r will have no effect - set line [string trim $line $bs] - #counterintuitively "x\b" still shows the x ie length is still one. The backspace just moves the position. There must be a char following \b for it to affect the length. - set n 0 - - set chars [split $line ""] - #build an output - set idx 0 - set outchars [list] - set outsizes [list] - foreach c $chars { - if {$c eq $bs} { - if {$idx > 0} { - incr idx -1 - } - } elseif {$c eq "\r"} { - set idx 0 - } else { - punk::ansi::internal::printing_length_addchar $idx $c - incr idx - } - } - set line2 [join $outchars ""] - return [punk::char::string_width $line2] - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::ansi ---}] -} - - -namespace eval punk::ansi { - - - # -- --- --- --- --- --- - #XTGETTCAP - # xterm responds with - # DCS 1 + r Pt ST for valid requests, adding to Pt an = , and - # the value of the corresponding string that xterm would send, - # or - # DCS 0 + r ST for invalid requests. - # The strings are encoded in hexadecimal (2 digits per - # character). If more than one name is given, xterm replies - # with each name/value pair in the same response. An invalid - # name (one not found in xterm's tables) ends processing of the - # list of names. - proc xtgetcap {keylist} { - #ESC P = 0x90 = DCS = Device Control String - set hexkeys [list] - foreach k $keylist { - lappend hexkeys [util::str2hex $k] - } - set payload [join $hexkeys ";"] - return "\x1bP+q$payload\x1b\\" - } - proc xtgetcap2 {keylist} { - #ESC P = 0x90 = DCS = Device Control String - set hexkeys [list] - foreach k $keylist { - lappend hexkeys [util::str2hex $k] - } - set payload [join $hexkeys ";"] - return "\u0090+q$payload\u009c" - } - 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} { - #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) - #Terminals should generally ignore it if they don't use it - regexp {\033\[[0-9;:]*m$} $code - } - proc is_cursor_move_in_line {code} { - #review - what about CSI n : m H where row n happens to be current line? - regexp {\033\[[0-9]*(:?C|D|G)$} - } - #pure SGR reset with no other functions - proc is_sgr_reset {code} { - #todo 8-bit csi - regexp {\033\[0*m$} $code - } - #whether this code has 0 (or equivalently empty) parameter (but may set others) - #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 - #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. - #Review - consider normalizing sgr codes to remove other redundancies such as setting fg or bg color twice in same code - proc has_sgr_leadingreset {code} { - set params "" - regexp {\033\[(.*)m} $code _match params - set plist [split $params ";"] - if {[string trim [lindex $plist 0] 0] eq ""} { - #e.g \033\[m \033\[0\;...m \033\[0000...m - return 1 - } else { - 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 { - proc is_Fe {code} { - # C1 control codes - if {[regexp {^\033\[[\u0040-\u005F]}]} { - #7bit - typical case - return 1 - } - #8bit - #review - all C1 escapes ? 0x80-0x90F - #This is possibly problematic as it is affected by encoding. - #According to https://en.wikipedia.org/wiki/ANSI_escape_code#8-bit - #"However, in character encodings used on modern devices such as UTF-8 or CP-1252, those codes are often used for other purposes, so only the 2-byte sequence is typically used." - return 0 - } - proc is_Fs {code} { - puts stderr "is_Fs unimplemented" - } - } - # -- --- --- --- --- --- --- --- --- --- --- - #todo - implement colour resets like the perl module: - #https://metacpan.org/pod/Text::ANSI::Util - #(saves up all ansi color codes since previous color reset and replays the saved codes after our highlighting is done) -} - - -namespace eval punk::ansi::ta { - #*** !doctools - #[subsection {Namespace punk::ansi::ta}] - #[para] text ansi functions - #[para] based on but not identical to the Perl Text Ansi module: - #[para] https://github.com/perlancar/perl-Text-ANSI-Util/blob/master/lib/Text/ANSI/BaseUtil.pm - #[list_begin definitions] - namespace path ::punk::ansi - - #handle both 7-bit and 8-bit csi - #review - does codepage affect this? e.g ebcdic has 8bit csi in different position - - #CSI - #variable re_csi_open {(?:\033\[|\u009b)[0-9;]+} ;#too specific - doesn't detect \033\[m - variable re_csi_open {(?:\033\[|\u009b)} - - #colour and style - variable re_csi_colour {(?:\033\[|\u009b)[0-9;]*m} ;#e.g \033\[31m \033\[m \033\[0m \033\[m0000m - #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). - variable re_csi_code {(?:\033\[|\u009b)[0-9;]*[a-zA-Z\\@^_|~`]} - - #OSC - termnate with BEL (\a \007) or ST (string terminator \033\\) - # 8-byte string terminator is \x9c (\u009c) - - #non-greedy via "*?" doesn't seem to work like this.. - #variable re_esc_osc1 {(?:\033\]).*?\007} - #variable re_esc_osc2 {(?:\033\]).*?\033\\} - #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).*} - - #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 - #review - only detect 'complete' codes - or just use the opening escapes for performance? - proc detect {text} { - #*** !doctools - #[call [fun detect] [arg text]] - #[para]Return a boolean indicating whether Ansi codes were detected in text - #[para] - - variable re_ansi_detect - #variable re_csi_open - #variable re_esc_osc1 - #variable re_esc_osc2 - #todo - other escape sequences - #expr {[regexp $re_csi_open $text] || [regexp $re_esc_osc1 $text] || [regexp $re_esc_osc2 $text]} - expr {[regexp $re_ansi_detect $text]} - } - #not in perl ta - proc detect_csi {text} { - #*** !doctools - #[call [fun detect_csi] [arg text]] - #[para]Return a boolean indicating whether an Ansi Control Sequence Introducer (CSI) was detected in text - #[para]The csi is often represented in code as \x1b or \033 followed by a left bracket [lb] - #[para]The initial byte or escape is commonly referenced as ESC in Ansi documentation - #[para]There is also a multi-byte escape sequence \u009b - #[para]This is less commonly used but is also detected here - #[para](This function is not in perl ta) - variable re_csi_open - expr {[regexp $re_csi_open $text]} - } - proc detect_sgr {text} { - #*** !doctools - #[call [fun detect_sgr] [arg text]] - #[para]Return a boolean indicating whether an ansi Select Graphics Rendition code was detected. - #[para]This is the set of CSI sequences ending in 'm' - #[para]This is most commonly an Ansi colour code - but also things such as underline and italics - #[para]An SGR with empty or a single zero argument is a reset of the SGR features - this is also detected. - #[para](This function is not in perl ta) - variable re_csi_colour - expr {[regexp $re_csi_colour $text]} - } - proc strip {text} { - #*** !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 - } - proc length {text} { - #*** !doctools - #[call [fun length] [arg text]] - #[para]Return the character length after stripping ansi codes - not the printing length - string length [stripansi $text] - } - #todo - handle newlines - #not in perl ta - #proc printing_length {text} { - # - #} - - proc trunc {text width args} { - - } - - #not in perl ta - #returns just the plaintext portions in a list - proc split_at_codes {text} { - variable re_esc_osc1 - variable re_esc_osc2 - variable re_csi_code - variable re_standalones - variable re_ST - punk::ansi::internal::splitx $text "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}|${re_standalones}|${re_ST}" - } - - # -- --- --- --- --- --- - #Split $text to a list containing alternating ANSI color codes and text. - #ANSI color codes are always on the second element, fourth, and so on. - #(ie plaintext on odd list-indices ansi on even indices) - # Example: - #ta_split_codes "" # => "" - #ta_split_codes "a" # => "a" - #ta_split_codes "a\e[31m" # => {"a" "\e[31m"} - #ta_split_codes "\e[31ma" # => {"" "\e[31m" "a"} - #ta_split_codes "\e[31ma\e[0m" # => {"" "\e[31m" "a" "\e[0m"} - #ta_split_codes "\e[31ma\e[0mb" # => {"" "\e[31m" "a" "\e[0m", "b"} - #ta_split_codes "\e[31m\e[0mb" # => {"" "\e[31m\e[0m" "b"} - # - proc split_codes {text} { - variable re_esc_osc1 - variable re_esc_osc2 - variable re_csi_code - 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] - } - #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) - proc split_codes_single {text} { - variable re_esc_osc1 - variable re_esc_osc2 - variable re_csi_code - 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] - } - - #review - tcl greedy expressions may match multiple in one element - proc _perlish_split {re text} { - if {[string length $text] == 0} { - return {} - } - set list [list] - 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]} { - 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] - set start [expr {$matchEnd+1}] - - #? - if {$start >= [string length $text]} { - break - } - } - lappend list [string range $text $start end] - return $list - } - proc _ws_split {text} { - regexp -all -inline {(?:\S+)|(?:\s+)} $text - } - # -- --- --- --- --- --- - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::ansi::ta ---}] -} -# -- --- --- --- --- --- --- --- --- --- --- - -namespace eval punk::ansi::ansistring { - #*** !doctools - #[subsection {Namespace punk::ansi::ansistring}] - #[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] - - namespace path [list ::punk::ansi ::punk::ansi::ta] - namespace ensemble create - 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 - probably obsolete? - #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 - - #C0 control code visual representations - # Code Val Name 2X Description - # 2400 00 NUL NU Symbol for Null - # 2401 01 SOH SH Symbol for Start of Heading - # 2402 02 STX SX Symbol for Start of Text - # 2403 03 ETX EX Symbol for End of Text - # 2404 04 EOT ET Symbol for End of Transmission - # 2405 05 ENQ EQ Symbol for Enquiry - # 2406 06 ACK AK Symbol for Acknowledge - # 2407 07 BEL BL Symbol for Bell - # 2409 09 BS BS Symbol for Backspace - # 2409 09 HT HT Symbol for Horizontal Tab (1) - # 240A 0A LF LF Symbol for Line Feed (1) - # 240B 0B VT VT Symbol for Vertical Tab (1) - # 240C 0C FF FF Symbol for Form Feed (2) - # 240D 0D CR CR Symbol for Carriage Return (1) - # 240E 0E SO SO Symbol for Shift Out - # 240F 0F SI SI Symbol for Shift In - # 2410 10 DLE DL Symbol for Data Link Escape - # 2411 11 DC1 D1 Symbol for Device Control 1 (2) - # 2412 12 DC2 D2 Symbol for Device Control 2 (2) - # 2413 13 DC3 D3 Symbol for Device Control 3 (2) - # 2414 14 DC4 D4 Symbol for Device Control 4 (2) - # 2415 15 NAK NK Symbol for Negative Acknowledge - # 2416 16 SYN SY Symbol for Synchronous Idle - # 2417 17 ETB EB Symbol for End of Transmission Block - # 2418 18 CAN CN Symbol for Cancel - # 2419 19 EM EM Symbol for End of Medium - # 241A 1A SUB SU Symbol for Substitute - # 241B 1B ESC EC Symbol for Escape - # 241C 1C FS FS Symbol for Field Separator (3) - # 241D 1D GS GS Symbol for Group Separator (3) - # 241E 1E RS RS Symbol for Record Separator (3) - # 241F 1F US US Symbol for Unit Separator (3) - # 2420 20 SP SP Symbol for Space (4) - # 2421 7F DEL DT Symbol for Delete (4) - - #C1 control code visual representations - #Code Val Name 2X Description - # 80 80 80 (1) - # 81 81 81 (1) - # E022 82 BPH 82 Symbol for Break Permitted Here (2) - # E023 83 NBH 83 Symbol for No Break Here (2) - # E024 84 IND IN Symbol for Index (3) - # E025 85 NEL NL Symbol for Next Line (4) - # E026 86 SSA SS Symbol for Start Selected Area - # E027 87 ESA ES Symbol for End Selected Area - # E028 88 HTS HS Symbol for Character Tabulation Set - # E029 89 HTJ HJ Symbol for Character Tabulation with Justification - # E02A 8A VTS VS Symbol for Line Tabulation Set - # E02B 8B PLD PD Symbol for Partial Line Forward - # E02C 8C PLU PU Symbol for Partial Line Backward - # E02D 8D RI RI Symbol for Reverse Line Feed - # E02E 8E SS2 S2 Symbol for Single Shift 2 - # E02F 8F SS3 S3 Symbol for Single Shift 3 - # E030 90 DCS DC Symbol for Device Control String - # E031 91 PU1 P1 Symbol for Private Use 1 - # E032 92 PU2 P2 Symbol for Private Use 2 - # E033 93 STS SE Symbol for Set Transmit State - # E034 94 CCH CC Symbol for Cancel Character - # E035 95 MW MW Symbol for Message Waiting - # E036 96 SPA SP Symbol for Start Protected (Guarded) Area - # E037 97 EPA EP Symbol for End Protected (Guarded) Area - # E038 98 SOS 98 Symbol for Start of String (2) - # 99 99 (1) - # E03A 9A SCI 9A Symbol for Single Character Introducer (2) - # E03B 9B CSI CS Symbol for Control Sequence Introducer (5) - # E03C 9C ST ST Symbol for String Terminator - # E03D 9D OSC OS Symbol for Operating System Command - # E03E 9E PM PM Symbol for Privacy Message - # E03F 9F APC AP Symbol for Application Program Command - - proc VIEW {args} { - #*** !doctools - #[call [fun VIEW] [arg string]] - #[para]Return a string with specific ANSI control characters substituted with visual equivalents frome the appropriate unicode C0 and C1 visualisation sets - #[para]For debugging purposes, certain other standard control characters are converted to visual representation, for example backspace (mapped to \\U2408 '\U2408') - #[para]Horizontal tab is mapped to \\U2409 '\U2409'. For many of the punk terminal text operations, tabs have already been mapped to the appropriate number of spaces using textutil::tabify functions - #[para]As punkshell uses linefeed where possible in preference to crlf even on windows, cr is mapped to \\U240D '\U240D' - but lf is left as is. - - if {![llength $args]} { - return "" - } - - set string [lindex $args end] - set defaults [dict create\ - -esc 1\ - -cr 1\ - -lf 0\ - -vt 0\ - -ht 1\ - -bs 1\ - -sp 1\ - ] - set argopts [lrange $args 0 end-1] - if {[llength $argopts] % 2 != 0} { - error "ansistring VIEW options must be option-value pairs, received '$argopts'. Known opts [dict keys $defaults]" - } - set opts [dict merge $defaults $argopts] - # -- --- --- --- --- - set opt_esc [dict get $opts -esc] - set opt_cr [dict get $opts -cr] - set opt_lf [dict get $opts -lf] - set opt_vt [dict get $opts -vt] - set opt_ht [dict get $opts -ht] - set opt_bs [dict get $opts -bs] - set opt_sp [dict get $opts -sp] - # -- --- --- --- --- - - - #modern (c0 seem to have more terminal/font support - C1 can show 8bit c1 codes - but also seems to be limited support) - - #Goal is not to map every control character? - #Map of which elements we want to convert - done this way so we can see names of control's that are included: - ease of maintenance compared to just creating the string map directly - #ETX -ctrl-c - #EOT ctrl-d (EOF?) - #SYN ctrl-v - #SUB ctrl-z - #CAN ctrl-x - #FS ctrl-\ (SIGQUIT) - set visuals_interesting [dict create\ - NUL [list \x00 \u2400]\ - ETX [list \x03 \u2403]\ - EOT [list \x04 \u2404]\ - BEL [list \x07 \u2407]\ - SYN [list \x16 \u2416]\ - CAN [list \x18 \u2418]\ - SUB [list \x1a \u241a]\ - FS [list \x1c \u241c]\ - SOS [list \x98 \ue038]\ - CSI [list \x9b \ue03b]\ - ST [list \x9c \ue03c]\ - PM [list \x9e \ue03e]\ - APC [list \x9f \ue03f]\ - ] - #it turns out we need pretty much everything for debugging - set visuals [dict create\ - NUL [list \x00 \u2400]\ - SOH [list \x01 \u2401]\ - STX [list \x02 \u2402]\ - ETX [list \x03 \u2403]\ - EOT [list \x04 \u2404]\ - ENQ [list \x05 \u2405]\ - ACK [list \x06 \u2406]\ - BEL [list \x07 \u2407]\ - FF [list \x0c \u240c]\ - SO [list \x0e \u240e]\ - SF [list \x0f \u240f]\ - DLE [list \x10 \u2410]\ - DC1 [list \x11 \u2411]\ - DC2 [list \x12 \u2412]\ - DC3 [list \x13 \u2413]\ - DC4 [list \x14 \u2414]\ - NAK [list \x15 \u2415]\ - SYN [list \x16 \u2416]\ - ETB [list \x17 \u2417]\ - CAN [list \x18 \u2418]\ - EM [list \x19 \u2419]\ - SUB [list \x1a \u241a]\ - FS [list \x1c \u241c]\ - GS [list \x1d \u241d]\ - RS [list \x1e \u241e]\ - US [list \x1f \u241f]\ - DEL [list \x7f \u2421]\ - SOS [list \x98 \ue038]\ - CSI [list \x9b \ue03b]\ - ST [list \x9c \ue03c]\ - PM [list \x9e \ue03e]\ - APC [list \x9f \ue03f]\ - ] - if {$opt_esc} { - dict set visuals VT [list \x1b \u241b] - } - if {$opt_cr} { - dict set visuals CR [list \x0d \u240d] - } - if {$opt_lf} { - dict set visuals LF [list \x0a \u240a] - } - if {$opt_vt} { - dict set visuals VT [list \x0b \u240b] - } - if {$opt_ht} { - dict set visuals HT [list \x09 \u2409] - } - if {$opt_bs} { - dict set visuals BS [list \x08 \u2408] - } - if {$opt_sp} { - dict set visuals SP [list \x20 \u2420] - } - - set charmap [list] - dict for {nm chars} $visuals { - lappend charmap {*}$chars - } - return [string map $charmap $string] - - #ISO2047 - 7bit - limited set, limited support - #return [string map [list \033 \U2296 \007 \U237E] $string] - } - - proc length {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} { - 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-+ 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 +- - 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 - #[list_end] [comment {--- end definitions namespace punk::ansi::ta ---}] -} - -namespace eval punk::ansi::internal { - proc splitn {str {len 1}} { - #from textutil::split::splitn - if {$len <= 0} { - return -code error "len must be > 0" - } - if {$len == 1} { - return [split $str {}] - } - set result [list] - set max [string length $str] - set i 0 - set j [expr {$len -1}] - while {$i < $max} { - lappend result [string range $str $i $j] - incr i $len - incr j $len - } - return $result - } - proc splitx {str {regexp {[\t \r\n]+}}} { - #from textutil::split::splitx - # Bugfix 476988 - if {[string length $str] == 0} { - return {} - } - if {[string length $regexp] == 0} { - return [::split $str ""] - } - if {[regexp $regexp {}]} { - return -code error \ - "splitting on regexp \"$regexp\" would cause infinite loop" - } - set list {} - set start 0 - while {[regexp -start $start -indices -- $regexp $str match submatch]} { - foreach {subStart subEnd} $submatch break - foreach {matchStart matchEnd} $match break - incr matchStart -1 - incr matchEnd - lappend list [string range $str $start $matchStart] - if {$subStart >= $start} { - lappend list [string range $str $subStart $subEnd] - } - set start $matchEnd - } - lappend list [string range $str $start end] - return $list - } - - proc printing_length_addchar {i c} { - upvar outchars outc - upvar outsizes outs - set nxt [llength $outc] - if {$i < $nxt} { - lset outc $i $c - } else { - lappend outc $c - } - } - - #string to 2digit hex - e.g used by XTGETTCAP - proc str2hex {input} { - set 2hex "" - foreach ch [split $input ""] { - append 2hex [format %02X [scan $ch %c]] - } - return $2hex - } - proc hex2str {2digithexchars} { - set 2digithexchars [string map [list _ ""] $2digithexchars] ;#compatibility with tcl tip 551 (compatibility in the sense that users might expect to be able to use underscores and it's nice to support the syntax here too - not that it's required) - if {$2digithexchars eq ""} { - return "" - } - if {[string length $2digithexchars] % 2 != 0} { - error "hex2str requires an even number of hex digits (2 per character)" - } - set 2str "" - foreach pair [splitn $2digithexchars 2] { - append 2str [format %c 0x$pair] - } - return $2str - } -} - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::ansi [namespace eval punk::ansi { - variable version - set version 0.1.0 -}] -return - - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm index ad2d58f4..15421402 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -3130,10 +3130,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } undt { - #CSI 58:5 UNDERLINE COLOR PALETTE INDEX - #CSI 58 : 5 : INDEX m - #variable TERM_colour_map - #256 colour underline by Xterm name or by integer + # CSI 58:5 UNDERLINE COLOR PALETTE INDEX + # CSI 58 : 5 : INDEX m + # variable TERM_colour_map + # 256 colour underline by Xterm name or by integer #name is xterm name or colour index from 0 - 255 set cc [tcl::string::tolower [tcl::string::range $i 5 end]] if {[tcl::string::is integer -strict $cc] & $cc < 256} { @@ -5202,9 +5202,10 @@ tcl::namespace::eval punk::ansi { #tcl::dict::set codestate_empty undersingle "" #tcl::dict::set codestate_empty underdouble "" #tcl::dict::set codestate_empty undercurly "" - #tcl::dict::set codestate_empty underdottedn "" + #tcl::dict::set codestate_empty underdotted "" #tcl::dict::set codestate_empty underdashed "" + tcl::dict::set codestate_empty blink "" ;#5 or 6 for slow/fast, 25 for off tcl::dict::set codestate_empty reverse "" ;#7 on 27 off tcl::dict::set codestate_empty hide "" ;#8 on 28 off @@ -5234,6 +5235,8 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate_empty fg "" ;#30-37 + 90-97 tcl::dict::set codestate_empty bg "" ;#40-47 + 100-107 + variable metastate_empty + tcl::dict::set metastate_empty underline_active "" ;#a meta state for whether underlines are on|off - values 1,0,"" #misnomer should have been sgr_merge_args ? :/ #as a common case optimisation - it will not merge a single element list, even if that code contains redundant elements @@ -5269,6 +5272,7 @@ tcl::namespace::eval punk::ansi { #(use punk::ansi::ta::split_codes_single) proc sgr_merge_singles {codelist args} { variable codestate_empty + variable metastate_empty variable defaultopts_sgr_merge_singles set opts $defaultopts_sgr_merge_singles foreach {k v} $args { @@ -5284,8 +5288,8 @@ tcl::namespace::eval punk::ansi { } set othercodes [list] - set codestate $codestate_empty - set codestate_initial $codestate_empty ;#keep a copy for resets. + set codestate $codestate_empty ;#take copy as we need the empty state for resets + set metastate $metastate_empty set did_reset 0 #we should also handle 8bit CSI here? mixed \x1b\[ and \x9b ? Which should be used in the merged result? @@ -5345,7 +5349,8 @@ tcl::namespace::eval punk::ansi { switch -- $codeint { "" - 0 { if {![tcl::dict::get $opts -filter_reset]} { - set codestate $codestate_initial + set codestate $codestate_empty + set metastate $metastate_empty set did_reset 1 } } @@ -5371,27 +5376,42 @@ tcl::namespace::eval punk::ansi { #e.g hyper on windows if {[llength $paramsplit] == 1} { tcl::dict::set codestate underline 4 + if {[tcl::dict::get $codestate underextended] eq "4:0"} { + tcl::dict::set codestate underextended "" + } + tcl::dict::set metastate underline_active 1 } else { switch -- [lindex $paramsplit 1] { 0 { #no *extended* underline #tcl::dict::set codestate underline 24 tcl::dict::set codestate underextended 4:0 ;#will not turn off SGR standard underline if term doesn't support extended + tcl::dict::set metastate underline_active 0 } 1 { + #single tcl::dict::set codestate underextended 4:1 + tcl::dict::set metastate underline_active 1 } 2 { + #double tcl::dict::set codestate underextended 4:2 + tcl::dict::set metastate underline_active 1 } 3 { + #curly tcl::dict::set codestate underextended "4:3" + tcl::dict::set metastate underline_active 1 } 4 { + #dotted tcl::dict::set codestate underextended "4:4" + tcl::dict::set metastate underline_active 1 } 5 { + #dashed tcl::dict::set codestate underextended "4:5" + tcl::dict::set metastate underline_active 1 } } @@ -5431,6 +5451,7 @@ tcl::namespace::eval punk::ansi { 24 { tcl::dict::set codestate underline 24 ;#off tcl::dict::set codestate underextended "4:0" ;#review + tcl::dict::set metastate underline_active 0 } 25 { tcl::dict::set codestate blink 25 ;#off @@ -5519,11 +5540,11 @@ tcl::namespace::eval punk::ansi { } 58 { #nonstandard - #256 colour or rgb + # 256 colour or rgb if {[tcl::string::first : $p] < 0} { switch -- [lindex $plist $i+1] { 5 { - #256 - 1 more param + # 256 - 1 more param tcl::dict::set codestate underlinecolour "58\;5\;[lindex $plist $i+2]" incr i 2 } @@ -5544,10 +5565,12 @@ tcl::namespace::eval punk::ansi { 60 { tcl::dict::set codestate ideogram_underline 60 tcl::dict::set codestate ideogram_clear "" + #nounderline effect? review! } 61 { tcl::dict::set codestate ideogram_doubleunderline 61 tcl::dict::set codestate ideogram_clear "" + #nounderline effect? review! } 62 { tcl::dict::set codestate ideogram_overline 62 @@ -5566,6 +5589,7 @@ tcl::namespace::eval punk::ansi { #review - we still need to pass through the ideogram_clear in case something understands it tcl::dict::set codestate ideogram_underline "" tcl::dict::set codestate ideogram_doubleunderline "" + tcl::dict::set codestate ideogram_overline "" tcl::dict::set codestate ideogram_doubleoverline "" } @@ -5623,6 +5647,7 @@ tcl::namespace::eval punk::ansi { } } underlinecolour - underextended { + #review append unmergeable "${v}\;" } default { @@ -5640,7 +5665,11 @@ tcl::namespace::eval punk::ansi { "" {} default { switch -- $k { - underlinecolour - underextended { + underlinecolour { + append unmergeable "${v}\;" + } + underextended { + #review append unmergeable "${v}\;" } default { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm deleted file mode 100644 index 91f29aa5..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm +++ /dev/null @@ -1,5314 +0,0 @@ -# -*- 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: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.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 punk::args 0.1.0 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.1.0] -#[copyright "2024"] -#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] -#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] -#[require punk::args] -#[keywords module proc args arguments parse] -#[description] -#[para]Utilities for parsing proc args - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). -#[para] overview of punk::args -#[subsection Concepts] -#[para]There are 2 main conventions for parsing a proc args list -#[list_begin enumerated] -#[enum] -#[para]leading option-value pairs and flags followed by a list of values (Tcl style) -#[enum] -#[para]leading list of values followed by option-value pairs and flags (Tk style) -#[list_end] -#[para]There are exceptions in both Tcl and Tk commands regarding this ordering -#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style -#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] -#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. -#[para] -#[para]The basic principle is that a call to punk::args::get_dict is made near the beginning of the proc with a cacheable first argument defining the parameters e.g -#[example { -# proc dofilestuff {args} { -# lassign [dict values [punk::args::get_dict { -# @cmd -help "do some stuff with files e.g dofilestuff " -# @opts -type string -# #comment lines ok -# -directory -default "" -# -translation -default binary -# #setting -type none indicates a flag that doesn't take a value (solo flag) -# -nocomplain -type none -# @values -min 1 -max -1 -# } $args]] leaders opts values -# -# puts "translation is [dict get $opts -translation]" -# foreach f [dict values $values] { -# puts "doing stuff with file: $f" -# } -# } -#}] -#[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls -#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values -#[para]valid @ lines being with @cmd @leaders @opts @values -#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. -#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. -#[para]e.g the result from the punk::args call above may be something like: -#[para] opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} -#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments -#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments -#[example { -# proc dofilestuff {category args} { -# lassign [dict values [punk::args::get_dict { -# -directory -default "" -# -translation -default binary -# -nocomplain -type none -# @values -min 2 -max 2 -# fileA -type existingfile 1 -# fileB -type existingfile 1 -# } $args]] leaders opts values -# puts "$category fileA: [dict get $values fileA]" -# puts "$category fileB: [dict get $values fileB]" -# } -#}] -#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 -#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored -#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, -#[para] or an additional call could be made to punk::args e.g -#[example { -# punk::args::get_dict { -# category -choices {cat1 cat2 cat3} -# another_leading_arg -type boolean -# } [list $category $another_leading_arg] -#}] - -#*** !doctools -#[subsection Notes] -#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. -#[para] -#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. -#For functions that are part of an API a package may be more suitable. -#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) -#[example { -# proc test_switch {args} { -# set opts [dict create\\ -# -return "object"\\ -# -frametype "heavy"\\ -# -show_edge 1\\ -# -show_seps 0\\ -# -x a\\ -# -y b\\ -# -z c\\ -# -1 1\\ -# -2 2\\ -# -3 3\\ -# ] -# foreach {k v} $args { -# switch -- $k { -# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { -# dict set opts $k $v -# } -# default { -# error "unrecognised option '$k'. Known options [dict keys $opts]" -# } -# } -# } -# return $opts -# } -#}] -#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. -#[para] -# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. -# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. -#[para]use punk::lib::show_jump_tables to verify that a jump table exists. -#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous -#[example { -# proc test_prefix {args} { -# set opts [dict create\ -# -return string\ -# -frametype \uFFEF\ -# -show_edge \uFFEF\ -# -show_seps \uFFEF\ -# -x a\ -# -y b\ -# -z c\ -# -1 1\ -# -2 2\ -# -3 3\ -# ] -# if {[llength $args]} { -# set knownflags [dict keys $opts] -# } -# foreach {k v} $args { -# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v -# } -# return $opts -# } -#}] -#[para]There are many alternative args parsing packages a few of which are listed here. -#[list_begin enumerated] -#[enum]argp (pure tcl) -#[enum]parse_args (c implementation) -#[enum]argparse (pure tcl *) -#[enum]cmdline (pure tcl) -#[enum]opt (pure tcl) distributed with Tcl but considered deprecated -#[enum]The tcllib set of TEPAM modules (pure tcl) -#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. -#[list_end] -#[para] (* c implementation planned/proposed) -#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. -#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences -#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. -#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. -#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. -#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. -#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -#All ensemble commands are slower in a safe interp as they aren't compiled the same way -#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 -#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. -#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) -#ensembles: array binary clock dict info namespace string -#possibly file too, although that is generally hidden/modified in a safe interp -#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc -#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::args -#[list_begin itemized] -package require Tcl 8.6- -#optional? punk::trie -#optional? punk::textblock -#*** !doctools -#[item] [package {Tcl 8.6-}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -tcl::namespace::eval punk::args::register { - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] cooperative namespace punk::args::register - #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded - #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. - #[list_begin definitions] - - #Although the actual punk::args::define calls are not too sluggish, there could be *many*. - #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, - #especially since a fair proportion may be for documentation purposes rather than parsing args. - - # -- --- --- --- --- --- --- --- - #cooperative with packages that define some punk args but do so lazily - #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first - variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective - if {![info exists ::punk::args::register::NAMESPACES]} { - set ::punk::args::register::NAMESPACES [list] - } - # -- --- --- --- --- --- --- --- - - variable loaded_packages [list] ;#fully loaded - variable loaded_info [dict create] ;#time - variable scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages - variable scanned_info [dict create] ;#time and idcount - #some packages, e.g punk::args::tclcore document other namespaces. - #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources - variable namespace_docpackages [dict create] - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::register ---}] -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args { - - - variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. - - tcl::namespace::export {[a-z]*} - variable rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} - variable id_cache_rawdef [tcl::dict::create] - variable id_cache_spec [tcl::dict::create] - - variable argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) - - variable argdata_cache [tcl::dict::create] - - variable id_counter 0 - - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] Core API functions for punk::args - #[list_begin definitions] - - #todo - some sort of punk::args::cherrypick operation to get spec from an existing set - #todo - doctools output from definition - - - - - #todo? -synonym/alias ? (applies to opts only not values) - #e.g -background -aliases {-bg} -default White - #review - how to make work with trie prefix - #e.g - # -corner -aliases {-corners} - # -centre -aliases {-center -middle} - #We mightn't want the prefix to be longer just because of an alias - #we should get -co -ce and -m from the above as abbreviations - - set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] - - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::define - #todo @preamble -help "move large block outside of table?" - @cmd -name punk::args::define -help\ - "Accepts a line-based definition of command arguments. - Returns a dictionary representing the argument specifications. - - The return result can generally be ignored, as the record is stored keyed on the - @id -id value from the supplied definition. - This specifications dictionary is structured for (optional) use within commands to - parse and validate the arguments - and is also used when retrieving definitions - (or parts thereof) for re-use. - - This can be used purely for documentation or called within a function to parse a mix - of leading values, switches/flags and trailing values. - - The overhead is favourably comparable with other argument processors - but none are - as fast as minimal code with a switch statement. For toplevel commands where a few - 10s of microseconds is immaterial, the validation and automated error formatting in - a table can be well worthwhile. For inner procs requiring utmost speed, the call can - be made only on the unhappy path when basic processing determines a mismatch - or it - can be left entirely as documentation for interactive use with: i ... - - The definition should usually contain an initial line of the form: @id -id ::somecmd - - Blank lines are ignored at the top level, ie if they are not part of another structure. - Similarly - lines at the top level begginning with the # character are ignored. - All other toplevel lines must consist of a leading word followed by paired arguments. - The arguments can be spread over multiple lines and contain lines of near-arbitrary - text if they are properly braced or double quoted and Tcl escaping for inner quotes - or unbalanced braces is maintained. - The line continuation character - (\\ at the end of the line) can be used to continue the set of arguments for - a leading word. - Leading words beginning with the @ character are directives controlling argument - parsing and help display. - directives include: - %B%@id%N% ?opt val...? - spec-options: -id - %B%@cmd%N% ?opt val...? - spec-options: -name -help - %B%@leaders%N% ?opt val...? - spec-options: -min -max - (used for leading args that come before switches/opts) - %B%@opts%N% ?opt val...? - spec-options: -any - %B%@values%N% ?opt val...? - spec-options: -min -max - (used for trailing args that come after switches/opts) - %B%@argdisplay%N% ?opt val...? - spec-options: -header (text for header row of table) - -body (text to replace autogenerated arg info) - %B%@doc%N% ?opt val...? - spec-options: -name -url - %B%@seealso%N% ?opt val...? - spec-options: -name -url (for footer - unimplemented) - - Some other spec-options normally present on custom arguments are available - to use with the @leaders @opts @values directives to set defaults - for subsequent lines that represent your custom arguments. - These directives should occur in exactly this order - but can be - repeated with custom argument lines interspersed. - - An @id line can only appear once and should be the first item. - For the commandline usage to be displayed either on parsing error - or using the i .. function - an @id with -id is needed. - - All directives can be omitted, in which case every line represents - a custom leader, value or option. - All will be leaders by default if no options defined. - If options are defined (by naming with leading dash, or explicitly - specifying @opts) then the definitions prior to the options will be - categorised as leaders, and those following the options will be - categorised as values. - - Custom arguments are defined by using any word at the start of a - line that doesn't begin with @ or - - (except that adding an additionl @ escapes this restriction so - that @@somearg becomes an argument named @somearg) - - custom leading args, switches/options (names starting with -) - and trailing values also take spec-options: - - -type - defaults to string. If no other restrictions - are specified, choosing string does the least validation. - recognised types: - none - (used for switches only. Indicates this is - a 'solo' flag ie accepts no value) - int|integer - list - dict - double - bool|boolean - char - file - directory - string - ansistring - globstring - (any of the types accepted by 'string is') - - These all perform some validation checks - - and more.. (todo - document here) - - -optional - (defaults to true for flags/switches false otherwise) - For non flag/switch arguments - all arguments with - -optional true must sit consecutively within their group. - ie all optional leader arguments must be together, and all - optional value arguments must be together. Furthermore, - specifying both optional leaders and optional values will - often lead to ambiguous parsing results. Currently, all - optional non-flg/switch arguments should be either at the - trailing end of leaders or the trailing end of values. - Further unambiguous arrangements of optional args may be - made in future - but are currently considered 'unsupported' - -default - -multiple (for leaders & values defines whether - subsequent received values are stored against the same - argument name - only applies to final leader OR final value) - (for options/flags this allows the opt-val pair or solo - flag to appear multiple times - not necessarily contiguously) - -choices {} - A list of allowable values for an argument. - The -default value doesn't have to be in the list. - If a -type is specified - it doesn't apply to choice members. - It will only be used for validation if the -choicerestricted - option is set to false. - -choicerestricted - Whether values not specified in -choices or -choicegroups are - allowed. Defaults to true. - -choiceprefix - This specifies whether unique prefixes are able to be used - instead of the complete string. This is calculated using - tcl::prefix::match - and will display in the autogenerated - usage output. Defaults to true. - -choiceprefixdenylist {} - These choices should match exactly a choice entry in one of - the settings -choices or -choicegroups. - These will still be used in prefix calculation - but the full - choice argument must be entered to select the choice. - -choicegroups {} - Generally this would be used instead of -choices to allow - usage display of choices grouped by some name. - See for example the output if 'i zlib' where choices of the - next subcommand are grouped by the names compression,channel, - streaming and checksumming. The -choices list is equivalent - to a -choicegroups dict entry where the key (groupname) is - the empty string. - -choicemultiple (default {1 1}) - is a pair representing min and max number of choices - that can be present in the value. - If is a single integer it is equivalent to a - specified with the same integer for both min and max. - Max of -1 represents no upper limit. - If allows more than one choice the value is a list - consisting of items in the choices made available through - entries in -choices/-choicegroups. - -minsize (type dependant) - -maxsize (type dependant) - -range (type dependant) - - - " - -dynamic -type boolean -default 0 -help\ - "If -dynamic is true, tstr interpolations of the form \$\{\$var\} - are re-evaluated on each call. - If the definition is being used not just as documentation, but is also - used within the function to parse args, e.g using punk::args::get_by_id, - then it should be noted that there is a slight performance penalty for the - dynamic case. - It is often not significant, perhaps depending on what vars/commands are - used but -dynamic true might be less desirable if the command is used in - inner loops in more performance-sensitive code. - " - @values -min 1 -max -1 - text -type string -multiple 1 -help\ - "Block(s) of text representing the argument definition for a command. - At least one must be supplied. If multiple, they are joined together with \\n. - Using multiple text arguments may be useful to mix curly-braced and double-quoted - strings to have finer control over interpolation when defining arguments. - (this can also be handy for sections that pull resolved definition lines - from existing definitions (by id) for re-use of argument specifications and help text) - - e.g the following definition passes 2 blocks as text arguments - definition { - @id -id ::myns::myfunc - @cmd -name myns::myfunc -help\\ - \"Description of command\" - - #The following option defines an option-value pair - -option1 -default blah -type string - #The following option defines a flag style option (solo) - -flag1 -default 0 -type none -help\\ - \"Info about flag1 - subsequent help lines auto-dedented by whitespace to left - of corresponding record start (in this case -flag1) - + first 4 spaces if they are all present. - This line has no extra indent relative to first line 'Info about flag1' - This line indented a further 6 chars\" - - @values -min 1 -max -1 - #Items that don't begin with * or - are value definitions - v1 -type integer -default 0 - thinglist -type string -multiple 1 - } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" - " - }]] - - proc New_command_form {name} { - #probably faster to inline a literal dict create in the proc than to use a namespace variable - set leaderspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - set optspec_defaults [tcl::dict::create\ - -type string\ - -optional 1\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - set valspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - - #form record can have running entries such as 'argspace' that aren't given to arg parser - #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict - return [dict create\ - argspace "leaders"\ - ARG_INFO [tcl::dict::create]\ - ARG_CHECKS [tcl::dict::create]\ - LEADER_DEFAULTS [tcl::dict::create]\ - LEADER_REQUIRED {}\ - LEADER_NAMES {}\ - LEADER_MIN ""\ - LEADER_MAX ""\ - leaderspec_defaults $leaderspec_defaults\ - LEADER_CHECKS_DEFAULTS {}\ - opt_default {}\ - opt_required {}\ - OPT_NAMES {}\ - opt_any {}\ - opt_solos {}\ - optspec_defaults $optspec_defaults\ - OPT_CHECKS_DEFAULTS {}\ - val_defaults {}\ - val_required {}\ - VAL_NAMES {}\ - val_min ""\ - val_max ""\ - valspec_defaults $valspec_defaults\ - VAL_CHECKS_DEFAULTS {}\ - argdisplay_info ""\ - ] - - #set argdata_dict [tcl::dict::create\ - # id $DEF_definition_id\ - # arg_info $arg_info\ - # arg_checks $arg_checks\ - # leader_defaults $leader_defaults\ - # leader_required $leader_required\ - # leader_names $leader_names\ - # leader_min $leader_min\ - # leader_max $leader_max\ - # leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ - # leader_checks_defaults $leader_checks_defaults\ - # opt_defaults $opt_defaults\ - # opt_required $opt_required\ - # opt_names $opt_names\ - # opt_any $opt_any\ - # opt_solos $opt_solos\ - # optspec_defaults [dict get $F $firstformid optspec_defaults]\ - # opt_checks_defaults $opt_checks_defaults\ - # val_defaults $val_defaults\ - # val_required $val_required\ - # val_names $val_names\ - # val_min $val_min\ - # val_max $val_max\ - # valspec_defaults [dict get $F $firstformid valspec_defaults]\ - # val_checks_defaults $val_checks_defaults\ - # cmd_info $cmd_info\ - # doc_info $doc_info\ - # argdisplay_info $argdisplay_info\ - # id_info $id_info\ - # form_defs $F\ - #] - } - proc define {args} { - dict get [resolve {*}$args] id - } - proc resolve {args} { - variable rawdef_cache - variable id_cache_rawdef - if {[dict exists $rawdef_cache $args]} { - set id [dict get $rawdef_cache $args -id] - set is_dynamic [dict get $rawdef_cache $args -dynamic] - } else { - set id [rawdef_id $args] - set is_dynamic [rawdef_is_dynamic $args] - dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] - dict set id_cache_rawdef $id $args - } - - - variable argdata_cache - variable argdefcache_unresolved - - - set cache_key $args - #ideally we would use a fast hash algorithm to produce a short key with low collision probability. - #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) - #review - check if there is a built-into-tcl way to do this quickly - #for now we will just key using the whole string - #performance seems ok - memory usage probably not ideal - #quote from DKF 2021 - #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. - #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. - #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. - #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). - #> If dealing with very large amounts of data, using a database is probably a good plan. - - set textargs $args - if {![llength $args]} { - punk::args::get_by_id ::punk::args::define {} - return - } - if {[lindex $args 0] eq "-dynamic"} { - set is_dynamic [lindex $args 1] - set textargs [lrange $args 2 end] - } - - if {!$is_dynamic} { - if {[tcl::dict::exists $argdata_cache $cache_key]} { - return [tcl::dict::get $argdata_cache $cache_key] - } - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - if {[string first \$\{ $optionspecs] > 0} { - set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } - } else { - #we are always doing our first subst during the define.. shouldn't it be a separate resolve somehow? optionally so at least? - - if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { - set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel 1 [list ::subst $param]] - } - } else { - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) - if {[string first \$\{ $optionspecs] > 0} { - set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel 1 [list ::subst $param]] - } - tcl::dict::set argdefcache_unresolved $cache_key $pt_params - } - } - #argdata_cache should be limited in some fashion or will be a big memory leak??? - if {[tcl::dict::exists $argdata_cache $optionspecs]} { - #resolved cache version exists - return [tcl::dict::get $argdata_cache $optionspecs] - } - } - - - - #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices - #default to 1 for convenience - - #checks with no default - #-minsize -maxsize -range - - - #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi - #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist - set opt_required [list] - set val_required [list] - - set opt_defaults [tcl::dict::create] - - set val_defaults [tcl::dict::create] - set opt_solos [list] - #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end - - set records [list] - set linebuild "" - - set linelist [split $optionspecs \n] - set lastindent "" - foreach ln $linelist { - if {[tcl::string::trim $ln] eq ""} {continue} - regexp {(\s*).*} $ln _all lastindent - break ;#break at first non-empty - } - #puts "indent1:[ansistring VIEW $lastindent]" - set in_record 0 - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - foreach rawline $linelist { - set recordsofar [tcl::string::cat $linebuild $rawline] - #ansi colours can stop info complete from working (contain square brackets) - #review - when exactly are ansi codes allowed/expected in record lines. - # - we might reasonably expect them in default values or choices or help strings - # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. - # - eg set line "set x \"a[a+ red]red[a]\"" - # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket - if {$has_punkansi} { - set test_complete [punk::ansi::ansistrip $recordsofar] - } else { - #review - #we only need to strip enough to stop interference with 'info complete' - set test_complete [string map [list \x1b\[ ""] $recordsofar] - } - if {![tcl::info::complete $test_complete]} { - #append linebuild [string trimleft $rawline] \n - if {$in_record} { - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. - #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. - #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. - #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) - #(note string first "" $str is fast and returns -1) - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline \n - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline \n - } else { - append linebuild $rawline \n - } - } else { - set in_record 1 - regexp {(\s*).*} $rawline _all lastindent - #puts "indent: [ansistring VIEW -lf 1 $lastindent]" - #puts "indent from rawline:$rawline " - append linebuild $rawline \n - } - } else { - set in_record 0 - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline - } else { - append linebuild $rawline - } - lappend records $linebuild - set linebuild "" - } - } - set cmd_info {} - set package_info {} - set id_info {} ;#e.g -children ?? - set doc_info {} - set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table - set seealso_info {} - set keywords_info {} - ###set leader_min 0 - ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit - #set leader_max "" - #(common case of no leaders specified) - set opt_any 0 - set val_min 0 - set val_max -1 ;#-1 for no limit - set DEF_definition_id $id - - #form_defs - set F [dict create _default [New_command_form _default]] - set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under - - #set ARGSPACE [dict create] ;#keyed on form - #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values - - set refs [dict create] - set record_type "" - set record_number -1 ;# - foreach rec $records { - set trimrec [tcl::string::trim $rec] - switch -- [tcl::string::index $trimrec 0] { - "" - # {continue} - } - incr record_number - set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict - if {[llength $record_values] % 2 != 0} { - #todo - avoid raising an error - store invalid defs keyed on id - error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" - } - # ---------------------------------------------------------- - # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. - #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! - #(form_ids_active is otherwise set in the @form handling block) - - #consider the following 2 line entry which is potentially dynamically included via a tstr: - # @form -form {* newform} - # @form -form {newform} -synopsis "cmd help ?stuff?" - #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. - #(because _default is usually 'taken over' by the first encountered form id) - #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record - #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. - - if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { - set patterns [dict get $record_values -form] - set record_form_ids [list] - foreach p $patterns { - if {[regexp {[*?\[\]]} $p]} { - #isglob - only used for matching existing forms - lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] - } else { - #don't test for existence - will define new form if necessary - lappend record_form_ids $p - } - } - #-form values could be globs that didn't match. record_form_ids could be empty.. - if {[llength $record_form_ids]} { - #only rename _default if it's the sole entry - if {[dict size $F] == 1 && [dict exists $F "_default"]} { - if {"_default" ni $record_form_ids} { - #only initial form exists - but we are mentioning new ones - #first rename the _default to first encountered new form id - #(just replace whole dict with new key - same data) - set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] - #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F - #we are only setting active because of the rename - @form is the way to change active forms list - set form_ids_active [lindex $record_form_ids 0] - } - } - foreach fid $record_form_ids { - if {![dict exists $F $fid]} { - if {$firstword eq "@form"} { - #only @form directly supplies keys - dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] - } else { - dict set F $fid [New_command_form $fid] - } - } else { - #update form with current record opts, except -form - if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } - } - } - } - } else { - #missing or empty -form - set record_form_ids $form_ids_active - if {$firstword eq "@form"} { - foreach fid $form_ids_active { - dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] - } - } - } - # ---------------------------------------------------------- - - set firstchar [tcl::string::index $firstword 0] - set secondchar [tcl::string::index $firstword 1] - if {$firstchar eq "@" && $secondchar ne "@"} { - set record_type "directive" - set directive_name $firstword - set at_specs $record_values - - switch -- [tcl::string::range $directive_name 1 end] { - dynamic { - set is_dynamic 1 - } - id { - #disallow duplicate @id line ? - #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) - - #id An id will be allocated if no id line present or the -id value is "auto" - - if {[dict exists $at_specs -id]} { - set thisid [dict get $at_specs -id] - if {$thisid ni [list $id auto]} { - error "punk::args::define @id mismatch existing: $id vs $thisid" - } - } - set id_info $at_specs - } - ref { - #a reference within the definition - #e.g see punk::args::tclcore ::after - #global reference dict - independent of forms - #ignore refs without an -id - #store all keys except -id - #complete overwrite if refid repeated later on - if {[dict exists $at_specs -id]} { - dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] - } - } - default { - #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple - #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) - #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) - #That is possibly too complicated and/or unnecessary? - #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? - - if {[dict exists $at_specs -id]} { - set copyfrom [get_spec [dict get $at_specs -id]] - #we don't copy the @id info from the source - #for now we only copy across if nothing set.. - #todo - bring across defaults for empty keys at targets? - #need to keep it simple enough to reason about behaviour easily.. - if {[dict size $copyfrom]} { - if {![dict size $cmd_info]} { - set cmd_info [dict get $copyfrom cmd_info] - } - if {![dict size $doc_info]} { - set doc_info [dict get $copyfrom doc_info] - } - foreach fid $record_form_ids { - #only use elements with matching form id? - #probably this feature mainly useful for _default anyway so that should be ok - #cooperative doc sets specified in same file could share via known form ids too - #todo argdisplay_info by fid - if {![dict size $argdisplay_info]} { - set argdisplay_info [dict get $copyfrom argdisplay_info] - } - #TODO - #create leaders opts vals depending on position of @default line? - #options on @default line to exclude/include sets??? - } - } - } - } - form { - # arity system ? - #handle multiple parsing styles based on arities and keyword positions (and/or flags?) - #e.g see lseq manual with 3 different parsing styles. - #aim to produce a table/subtable for each - # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ - # -arities { - # 2 - # {3 anykeys {1 .. 1 to}} - # {4 anykeys {3 by}} - # {5 anykeys {1 .. 1 to 3 by}} - # }\ - # -fallback 1 - # ... - # @parser -synopsis "start 'count' count ??'by'? step?"\ - # -arities { - # {3 anykeys {1 count}} - # } - # ... - # @form -synopsis "count ?'by' step?"\ - # -arities { - # 1 - # {3 anykeys {1 by}} - # } - # - # see also after manual - # @form -arities {1} - # @form -arities { - # 1 anykeys {0 info} - # } - #todo - - #can we generate a form synopsis if -synopsis not supplied? - - #form id can be list of ints|names?, or * - if {[dict exists $at_specs -form]} { - set idlist [dict get $at_specs -form] - if {$idlist eq "*"} { - #* only applies to form ids that exist at the time - set idlist [dict keys $F] - } - set form_ids_active $idlist - } - #new form keys already created if they were needed (done for all records that have -form ) - } - package { - set package_info [dict merge $package_info $at_specs] - } - cmd { - #allow arbitrary - review - set cmd_info [dict merge $cmd_info $at_specs] - } - doc { - set doc_info [dict merge $doc_info $at_specs] - } - argdisplay { - #override the displayed argument table. - #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing - set argdisplay_info [dict merge $argdisplay_info $at_specs] - } - opts { - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "values"} { - error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" - } - dict set F $fid argspace "options" - set tmp_optspec_defaults [dict get $F $fid optspec_defaults] - - foreach {k v} $at_specs { - switch -- $k { - -any - - -anyopts { - set opt_any $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { - #review - only apply to certain types? - tcl::dict::set tmp_optspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_optspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - none - "" - - - any - ansistring - globstring - list { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_optspec_defaults -type $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - #allow overriding of defaults for options that occur later - tcl::dict::set tmp_optspec_defaults $k $v - } - default { - set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" - } - } - } - dict set F $fid optspec_defaults $tmp_optspec_defaults - } ;# end foreach record_form_ids - } - leaders { - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] in [list options values]} { - error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" - } - set tmp_leaderspec_defaults [dict get $F $fid leaderspec_defaults] - - foreach {k v} $at_specs { - switch -- $k { - -min - - -minvalues { - if {$v < 0} { - error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MIN $v - #if {$leader_max == 0} { - # set leader_max -1 - #} - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MAX $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -choiceinfo { - if {[llength $v] %2 != 0} { - error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - #-choicegroups? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_leaderspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set tmp_leaderspec_defaults $k $v - } - default { - set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid leaderspec_defaults $tmp_leaderspec_defaults - - } ;#end foreach record_form_ids - - } - values { - foreach fid $record_form_ids { - dict set F $fid argspace "values" - - set tmp_valspec_defaults [dict get $F $fid valspec_defaults] - - foreach {k v} $at_specs { - switch -- $k { - -form { - } - -min - - -minvalues { - if {$v < 0} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" - } - set val_min $v - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" - } - set val_max $v - } - -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_valspec_defaults $k $v - } - -choiceinfo - -choicegroups { - if {[llength $v] % 2 != 0} { - error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - # -choicegroups ?? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_valspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set tmp_valspec_defaults $k $v - } - default { - set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid valspec_defaults $tmp_valspec_defaults - } - - } - seealso { - #todo! - #like @doc, except displays in footer, multiple - sub-table? - set seealso_info [dict merge $seealso_info $at_specs] - } - keywords { - #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? - set keywords_info [dict merge $keywords_info $at_specs] - } - default { - error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @argdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" - } - } - #record_type directive - continue - } elseif {$firstchar eq "-"} { - set argname $firstword - set argdef_values $record_values - tcl::dict::set argdef_values -ARGTYPE option - - - - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - dict set F $fid argspace "options" - } elseif {[dict get $F $fid argspace] eq "values"} { - error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" - } - set record_type option - dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] - #lappend opt_names $argname - } - - set is_opt 1 - } else { - set argname $firstword - if {$firstchar eq "@"} { - #allow basic @@ escaping for literal argname that begins with @ - set argname [tcl::string::range $argname 1 end] - } - - set argdef_values $record_values - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - set record_type leader - tcl::dict::set argdef_values -ARGTYPE leader - #lappend leader_names $argname - set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] - if {$argname ni $temp_leadernames} { - lappend temp_leadernames $argname - tcl::dict::set F $fid LEADER_NAMES $temp_leadernames - } else { - error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" - } - - if {[dict get $F $fid LEADER_MAX] >= 0} { - dict set F $fid LEADER_MAX [llength $temp_leadernames] - } - } else { - set record_type value - tcl::dict::set argdef_values -ARGTYPE value - set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] - lappend temp_valnames $argname - tcl::dict::set F $fid VAL_NAMES $temp_valnames - #lappend val_names $argname - } - } - - set is_opt 0 - } - - - #assert - we only get here if it is a value or flag specification line. - #assert argdef_values has been set to the value of record_values - - foreach fid $record_form_ids { - if {$is_opt} { - set spec_merged [dict get $F $fid optspec_defaults] - } else { - if {[dict get $F $fid argspace] eq "values"} { - set spec_merged [dict get $F $fid valspec_defaults] - } else { - set spec_merged [dict get $F $fid leaderspec_defaults] - } - } - - # -> argopt argval - foreach {spec specval} $argdef_values { - #literal-key switch - bytecompiled to jumpTable - switch -- $spec { - -form { - - } - -type { - #normalize here so we don't have to test during actual args parsing in main function - switch -- [tcl::string::tolower $specval] { - int - integer { - tcl::dict::set spec_merged -type int - } - bool - boolean { - tcl::dict::set spec_merged -type bool - } - char - character { - tcl::dict::set spec_merged -type char - } - dict - dictionary { - tcl::dict::set spec_merged -type dict - } - "" - none { - if {$is_opt} { - tcl::dict::set spec_merged -type none - 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 - error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" - } - } - any - anything { - tcl::dict::set spec_merged -type any - } - ansi - ansistring { - tcl::dict::set spec_merged -type ansistring - } - any - string - globstring { - tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - } - default { - #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW - tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - } - } - } - -default - -solo - -range - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo - - -minsize - -maxsize - -nocase - -optional - -multiple - - -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - - -regexprepass - -regexprefail - -regexprefailmsg - { - #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines - #review -solo 1 vs -type none ? conflicting values? - tcl::dict::set spec_merged $spec $specval - } - -validationtransform { - #string is dict only 8.7/9+ - if {[llength $specval] % 2} { - error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" - } - dict for {tk tv} $specval { - switch -- $tk { - -function - -type - -minsize - -maxsize - -range { - } - default { - set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? - error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" - } - } - } - - } - default { - if {[string match ref-* $spec]} { - #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) - #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. - if {![tcl::dict::exists $refs $specval]} { - puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" - } else { - set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" - if {$targetswitch eq "-*"} { - set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id - } else { - if {[tcl::dict::exists $refs $specval $targetswitch]} { - tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] - } else { - puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" - } - } - } - } else { - set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - ] - error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" - } - } - } - } ;# end foreach {spec specval} argdef_values - - - if {$is_opt} { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } else { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - tcl::dict::set F $fid ARG_INFO $argname $spec_merged - #review existence of -default overriding -optional - if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { - if {$is_opt} { - lappend opt_required $argname - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - set temp_leader_required [dict get $F $fid LEADER_REQUIRED] - lappend temp_leader_required $argname - dict set F $fid LEADER_REQUIRED $temp_leader_required - #lappend leader_required $argname - } else { - lappend val_required $argname - } - } - } - if {[tcl::dict::exists $spec_merged -default]} { - if {$is_opt} { - tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } else { - tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] - } - } - } - } ;# end foreach fid record_form_ids - - } ;# end foreach rec $records - - - #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { - # variable id_counter - # set DEF_definition_id "autoid_[incr id_counter]" - #} - - - #check ALL forms not just form_ids_active (record_form_ids) - dict for {fid formdata} $F { - # REVIEW - #no values specified - we can allow last leader to be multiple - foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { - error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" - } - } - #confirm any valnames before last don't have -multiple key - foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { - error "bad key -multiple on argument spec for value '$valname' in command form:'$fid'. Only the last value argument specification can be marked -multiple @id:$DEF_definition_id" - } - } - - #todo - document that ambiguities in API are likely if both @leaders and @values used - #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) - - - dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - - - - - #todo - precalculate a set of 'arity' entries for each form - #We want a structure for the arg parser to get easy access and make a fast decision on which form applies - #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? - #1) after ms (1 1) - #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? - #3) after cancel id (2 2) - #4) after cancel script ?script...? (2 -1) - #5) after idle script ?script...? (1 -1) - #6) after info ?id? (1 2) - - #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) - - #in the above case we have no unique total_arity - #we would also want to consider values when selecting - #e.g given the invalid command "after cancel" - # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. - - - - set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands - #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use - #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form - #e.g commandline completion could show list of synopsis entries to select from - - set form_info [dict create] - dict for {fid fdict} $F { - dict set form_info $fid {} - dict for {optk optv} $fdict { - if {[string match -* $optk]} { - dict set form_info $fid $optk $optv - } - } - } - - set argdata_dict [tcl::dict::create\ - id $DEF_definition_id\ - ARG_INFO [dict get $F $firstformid ARG_INFO]\ - ARG_CHECKS [dict get $F $firstformid ARG_CHECKS]\ - LEADER_DEFAULTS [dict get $F $firstformid LEADER_DEFAULTS]\ - LEADER_REQUIRED [dict get $F $firstformid LEADER_REQUIRED]\ - LEADER_NAMES [dict get $F $firstformid LEADER_NAMES]\ - LEADER_MIN [dict get $F $firstformid LEADER_MIN]\ - LEADER_MAX [dict get $F $firstformid LEADER_MAX]\ - leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ - LEADER_CHECKS_DEFAULTS [dict get $F $firstformid LEADER_CHECKS_DEFAULTS]\ - opt_defaults $opt_defaults\ - opt_required $opt_required\ - OPT_NAMES [dict get $F $firstformid OPT_NAMES]\ - opt_any $opt_any\ - opt_solos $opt_solos\ - optspec_defaults [dict get $F $firstformid optspec_defaults]\ - OPT_CHECKS_DEFAULTS [dict get $F $firstformid OPT_CHECKS_DEFAULTS]\ - val_defaults $val_defaults\ - val_required $val_required\ - VAL_NAMES [dict get $F $firstformid VAL_NAMES]\ - val_min $val_min\ - val_max $val_max\ - valspec_defaults [dict get $F $firstformid valspec_defaults]\ - VAL_CHECKS_DEFAULTS [dict get $F $firstformid VAL_CHECKS_DEFAULTS]\ - cmd_info $cmd_info\ - doc_info $doc_info\ - package_info $package_info\ - argdisplay_info $argdisplay_info\ - seealso_info $seealso_info\ - id_info $id_info\ - FORMS $F\ - form_names [dict keys $F]\ - FORM_INFO $form_info\ - ] - - tcl::dict::set argdata_cache $cache_key $argdata_dict - if {$is_dynamic} { - #also cache resolved version - tcl::dict::set argdata_cache $optionspecs $argdata_dict - } - - #tcl::dict::set id_cache_rawdef $DEF_definition_id $args - #puts "xxx:$result" - return $argdata_dict - } - - #return raw definition list as created with 'define' - # - possibly with unresolved dynamic parts - proc raw_def {id} { - variable id_cache_rawdef - set realid [real_id $id] - if {![dict exists $id_cache_rawdef $realid]} { - return "" - } - return [tcl::dict::get $id_cache_rawdef $realid] - } - - - namespace eval argdoc { - variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @argdisplay @seealso @leaders @opts @values leaders opts values} - variable resolved_def_TYPE_CHOICEGROUPS { - directives {@id @package @cmd @ref @doc @argdisplay @seealso} - argumenttypes {leaders opts values} - remaining_defaults {@leaders @opts @values} - } - - lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { - @id -id ::punk::args::resolved_def - @cmd -name punk::args::resolved_def -help\ - "Resolves or retrieves the previously resolved definition and - uses the 'spec' form to build a response in definition format. - - Pulling argument definition data from another function is a form - of tight coupling to the other function that should be done with - care. - - Note that the directives @leaders @opts @values may appear multiple - times in a source definition - applying defaults for arguments that - follow. When retrieving these - there is only a single result for - each that represents the defaults after all have been applied. - When retrieving -types * each of these will be positioned before - the arguments of that type - but this doesn't mean there was a single - leading directive for this argument type in the source definition. - Each argument has already had its complete specification recorded in - its own result. - - When manually specifying -types, the order @leaders then @opts then - @values must be maintained - but if they are placed before their - corresponding arguments, they will not affect the retrieved arguments - as these arguments are already fully spec'd. The defaults from the - source can be removed by adding @leaders, @opts @values to the - -antiglobs list, but again - this won't affect the existing arguments. - Each argument can have members of its spec overridden using the - -override dictionary. - " - @leaders -min 0 -max 0 - @opts - -return -default text -choices {text dict} - -form -default 0 -help\ - "Ordinal index or name of command form" - - #no restriction on number of types/repetitions? - -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} - -antiglobs -default {} -type list -help\ - "Glob patterns for directive or argument/flags to - be suppressed" - -override -type dict -optional 1 -default "" -help\ - "dict of dicts. Key in outer dict is the name of a - directive or an argument. Inner dict is a map of - overrides/additions (- ...) for that line. - " - @values -min 1 -max -1 - id -type string -help\ - "identifer for a punk::args definition - This will usually be a fully-qualifed - path for a command name" - pattern -type string -optional 1 -default * -multiple 1 -help\ - "glob-style patterns for retrieving value or switch - definitions. - - If -type is * and pattern is * the entire definition including - directive lines will be returned in line form. - (directives are lines beginning with - @ e.g @id, @cmd etc) - - if -type is leaders,opts or values matches from that type - will be returned. - - if -type is another directive such as @id, @doc etc the - patterns are ignored. - - " - }]] - } - - - proc resolved_def {args} { - #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. - set opts [dict create\ - -return text\ - -types {}\ - -form 0\ - -antiglobs {}\ - -override {}\ - ] - if {[llength $args] < 1} { - #must have at least id - punk::args::parse $args withid ::punk::args::resolved_def - return - } - set patterns [list] - - #a definition id must not begin with "-" ??? review - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {$a in {-type -types}} { - incr i - dict set opts -types [lindex $args $i] - } elseif {[string match -* $a]} { - incr i - dict set opts $a [lindex $args $i] - } else { - set id [lindex $args $i] - set patterns [lrange $args $i+1 end] - break - } - if {$i == [llength $args]-1} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - if {![llength $patterns]} { - set patterns [list *] - } - dict for {k v} $opts { - switch -- $k { - -return - -form - -types - -antiglobs - -override {} - default { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - } - set typelist [dict get $opts -types] - if {[llength $typelist] == 0} { - set typelist {*} - } - foreach type $typelist { - if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - - - variable id_cache_rawdef - set realid [real_id $id] - if {$realid eq ""} { - return - } - - set deflist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] - - set opt_form [dict get $opts -form] - if {[string is integer -strict $opt_form]} { - set formname [lindex [dict get $specdict form_names] $opt_form] - } else { - set formname $opt_form - } - set opt_override [dict get $opts -override] - set opt_return [dict get $opts -return] - - #set arg_info [dict get $specdict ARG_INFO] - set arg_info [dict get $specdict FORMS $formname ARG_INFO] - set argtypes [dict create leaders leader opts option values value] - - set opt_antiglobs [dict get $opts -antiglobs] - set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] - set suppressed_directives [list] - set suppressed_args [list] - foreach ag $opt_antiglobs { - foreach d $directives { - if {[string match $ag $d]} { - lappend suppressed_directives $d - } - } - foreach argname [dict keys $arg_info] { - if {[string match $ag $argname]} { - lappend suppressed_args $argname - } - } - } - set suppressed_directives [lsort -unique $suppressed_directives] - set suppressed_args [lsort -unique $suppressed_args] - - set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] - - set globbed [list] - foreach pat $patterns { - set matches [dict keys $arg_info $pat] - lappend globbed {*}$matches - } - set globbed [lsort -unique $globbed] - set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args] - - set result "" - set resultdict [dict create] - foreach type $typelist { - switch -exact -- $type { - * { - if {"@id" in $included_directives} { - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - foreach directive {@package @cmd @doc @seealso @argdisplay} { - set dshort [string range $directive 1 end] - if {"$directive" in $included_directives} { - if {[dict exists $opt_override $directive]} { - append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict ${dshort}_info]" - dict set resultdict $directive [dict get $specdict ${dshort}_info] - } - } - } - #output ordered by leader, option, value - foreach pseudodirective {leaders opts values} tp {leader option value} { - set directive "@$pseudodirective" - switch -- $directive { - @leaders {set defaults_key leaderspec_defaults} - @opts {set defaults_key optspec_defaults} - @values {set defaults_key valspec_defaults} - } - - if {"$directive" in $included_directives} { - if {[dict exists $opt_override "$directive"]} { - append result \n "$directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict $defaults_key]" - dict set resultdict $directive [dict get $specdict $defaults_key] - } - } - - if {$pseudodirective in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq $tp} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "$m $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - - } - @id { - if {"@id" in $included_directives} { - #only a single id record can exist - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - } - @package - @cmd - @doc - @seealso - @argdisplay { - if {"$type" in $included_directives} { - set tp [string range $type 1 end] ;# @package -> package - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict ${tp}_info]" - dict set resultdict $type [dict get $specdict ${tp}_info] - } - } - } - @leaders - @opts - @values { - #these are the active defaults for further arguments - if {"$type" in $included_directives} { - switch -- $type { - @leaders {set defaults_key leaderspec_defaults} - @opts {set defaults_key optspec_defaults} - @values {set defaults_key valspec_defaults} - } - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict leaderspec_defaults]" - dict set resultdict $type [dict get $specdict leaderspec_defaults] - } - } - } - leaders - opts - values { - #pseudo-directives - if {$type in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "$m $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - default { - } - } - if {$opt_return eq "text"} { - return $result - } else { - return $resultdict - } - } - } - - proc resolved_def_values {id {patternlist *}} { - variable id_cache_rawdef - set realid [real_id $id] - if {$realid ne ""} { - set speclist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [resolve {*}$speclist] - set arg_info [dict get $specdict ARG_INFO] - set valnames [dict get $specdict VAL_NAMES] - set result "" - if {$patternlist eq "*"} { - foreach v $valnames { - set def [dict get $arg_info $v] - set def [dict remove $def -ARGTYPE] - append result \n "$v $def" - } - return $result - } else { - foreach pat $patternlist { - set matches [dict keys $arg_info $pat] - set matches [lsearch -all -inline -glob $valnames $pat] - foreach m $matches { - set def [dict get $arg_info $m] - set def [dict remove $def -ARGTYPE] - append result \n "$m $def" - } - } - return $result - } - } - } - #proc resolved_def_leaders ?? - #proc resolved_def_opts ?? - - proc get_spec {id} { - set rdef [raw_def $id] - if {$rdef eq ""} {return} - return [resolve {*}$rdef] - #if {[id_exists $id]} { - # return [resolve {*}[raw_def $id]] - #} - } - proc is_dynamic {id} { - variable id_cache_rawdef - variable rawdef_cache - set deflist [raw_def $id] - if {[dict exists $rawdef_cache $deflist -dynamic]} { - return [dict get $rawdef_cache $deflist -dynamic] - } - return [rawdef_is_dynamic $deflist] - #@dynamic only has meaning as 1st element of a def in the deflist - } - - #@id must be within first 4 lines of a block - or assign auto - #review - @dynamic block where -id not explicitly set? - disallow? - proc rawdef_id {rawdef} { - set id "" - foreach d $rawdef { - foreach ln [lrange [split $d \n] 0 4] { - if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { - if {$firstword eq "@id"} { - if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { - set id [dict get $rest -id] - break - } - } - } - } - if {$id ne ""} { - break - } - } - if {$id eq "" || [string tolower $id] eq "auto"} { - variable id_counter - set id "autoid_[incr id_counter]" - } - #puts "==>id: $id" - return $id - } - #test the rawdef for @dynamic directive - proc rawdef_is_dynamic {rawdef} { - #temporary - old way - set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] - if {$flagged_dynamic} { - return true - } - foreach d $rawdef { - if {[regexp {\s*(\S+)} $d _match firstword]} { - if {$firstword eq "@dynamic"} { - return true - } - } - } - return false - } - - variable aliases - set aliases [dict create] - - lappend PUNKARGS [list { - @id -id ::punk::args::get_ids - @cmd -name punk::args::get_ids -help\ - "return list of ids for argument definitions" - @values -min 0 -max 1 - match -default * -help\ - "exact id or glob pattern for ids" - }] - proc get_ids {{match *}} { - variable id_cache_rawdef - variable aliases - return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] - } - - #we don't automatically test for (autodef)$id - only direct ids and aliases - proc id_exists {id} { - variable aliases - if {[tcl::dict::exists $aliases $id]} { - return 1 - } - variable id_cache_rawdef - tcl::dict::exists $id_cache_rawdef $id - } - proc set_alias {alias id} { - variable aliases - dict set aliases $alias $id - } - proc unset_alias {alias} { - variable aliases - dict unset aliases $alias - } - proc get_alias {alias} { - variable aliases - if {[dict exists $aliases $alias]} { - return [tcl::dict::get $aliases $alias] - } - } - - proc real_id {id} { - variable id_cache_rawdef - variable aliases - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } else { - set check_updates [list [namespace qualifiers $id]] - if {![llength [update_definitions $check_updates]]} { - #nothing new loaded - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } else { - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } - } - } - - proc status {} { - upvar ::punk::args::register::NAMESPACES registered - upvar ::punk::args::register::loaded_packages loaded_packages - upvar ::punk::args::register::loaded_info loaded_info - upvar ::punk::args::register::scanned_packages scanned_packages - upvar ::punk::args::register::scanned_info scanned_info - set result "" - # [format %-${w0}s $idtail] - set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] - append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n - set width_c2 [string length "Scanned_ids"] - set width_c3 [string length "Scantime_us"] - set width_c4 [string length "Loaded_defs"] - set width_c5 [string length "Loadtime_us"] - set count_unloaded 0 - set count_loaded 0 - foreach ns $registered { - if {$ns in $scanned_packages} { - set ids [dict get $scanned_info $ns idcount] - set scan_us [dict get $scanned_info $ns time] - } else { - set ids "" - set scan_us "" - } - if {$ns in $loaded_packages} { - incr count_loaded - set ldefs [dict get $loaded_info $ns defcount] - set load_us [dict get $loaded_info $ns time] - } else { - incr count_unloaded - set ldefs "" - set load_us "" - } - append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n - } - append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" - return $result - } - - #scanned_packages (list) - #namespace_docpackages (dict) - proc update_definitions {{nslist *}} { - if {[set gposn [lsearch $nslist {}]] >= 0} { - lset nslist $gposn :: - } - upvar ::punk::args::register::NAMESPACES registered ;#list - upvar ::punk::args::register::loaded_packages loaded_packages ;#list - upvar ::punk::args::register::loaded_info loaded_info ;#dict - upvar ::punk::args::register::scanned_packages scanned_packages ;#list - upvar ::punk::args::register::scanned_info scanned_info ;#dict - upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict - - - #puts stderr "-->update_definitions '$nslist'" - #needs to run quickly - especially when no package namespaces to be scanned for argdefs - #e.g - gets called for each subcommand of an ensemble (could be many) - # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. - #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. - # -- --- --- --- --- --- - # common-case fast-path - - if {[llength $loaded_packages] == [llength $registered]} { - #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. - #assert - if all are registered - then all have been scanned ( - return {} - } - # -- --- --- --- --- --- - - set unscanned [punklib_ldiff $registered $scanned_packages] - if {[llength $unscanned]} { - foreach pkgns $unscanned { - set idcount 0 - set ts_start [clock microseconds] - if {[info exists ${pkgns}::PUNKARGS]} { - set seen_documentedns [list] ;#seen per pkgns - foreach definitionlist [set ${pkgns}::PUNKARGS] { - #namespace eval $evalns [list punk::args::define {*}$definitionlist] - set id [rawdef_id $definitionlist] - if {[string match autoid_* $id]} { - puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" - puts stderr "definition:\n" - foreach d $definitionlist { - set out "" - foreach ln [split $d \n] { - append out " " $ln \n - } - puts $out - } - continue - } - #todo - detect duplicate ids (last will silently win.. should be reported somewhere) - incr idcount - set documentedns [namespace qualifiers $id] - if {$documentedns eq ""} {set documentedns ::} - if {$documentedns ni $seen_documentedns} { - #don't add own ns as a key in namespace_docpackages - if {$documentedns ne $pkgns} { - dict lappend namespace_docpackages $documentedns $pkgns - } - lappend seen_documentedns $documentedns - } - } - } - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - dict set scanned_info $pkgns [dict create time $diff idcount $idcount] - #we count it as scanned even if PUNKARGS didn't exist - #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) - lappend scanned_packages $pkgns - } - } - - - - if {"*" in $nslist} { - set needed [punklib_ldiff $registered $loaded_packages] - } else { - set needed [list] - foreach pkgns $nslist { - if {$pkgns in $registered && $pkgns ni $loaded_packages} { - lappend needed $pkgns - } - #argdoc sub namespace is a standard place to put defs that match the namespace below - #(generally the PUNKARGS in a namespace should apply to own ns) - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { - lappend needed $docns - } - } - if {[dict exists $namespace_docpackages $pkgns]} { - #this namespace has other argdef sources - foreach docns [dict get $namespace_docpackages $pkgns] { - if {$docns ni $loaded_packages} { - lappend needed $docns - } - } - } - } - } - - - - set newloaded [list] - foreach pkgns $needed { - #puts stderr "update_definitions Loading: $pkgns" - set ts_start [clock microseconds] - set def_count 0 - if {![catch { - if {[info exists ${pkgns}::PUNKARGS]} { - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - namespace eval ${pkgns}::argdoc { - set epath [namespace path] - set pkgns [namespace parent] - if {$pkgns ni $epath} { - namespace path [list {*}$epath $pkgns] ;#add to tail - } - - } - set evalns $docns - } else { - set evalns $pkgns - } - foreach definitionlist [set ${pkgns}::PUNKARGS] { - namespace eval $evalns [list punk::args::define {*}$definitionlist] - incr def_count - } - } - - #process list of 2-element lists - if {[info exists ${pkgns}::PUNKARGS_aliases]} { - foreach adef [set ${pkgns}::PUNKARGS_aliases] { - punk::args::set_alias {*}$adef - } - } - } errMsg]} { - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - lappend loaded_packages $pkgns - lappend newloaded $pkgns - dict set loaded_info $pkgns [dict create time $diff defcount $def_count] - } else { - puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" - } - } - return $newloaded - } - - #for use within get_dict only - #This mechanism gets less-than-useful results for oo methods - #e.g {$obj} - proc Get_caller {} { - #set call_level -3 ;#for get_dict call - set call_level -4 - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - #puts "-->$cmdinfo" - #puts "-->[tcl::info::frame -3]" - while {[string last \n $cmdinfo] >= 1} { - #looks like a script - haven't gone up far enough? - #(e.g patternpunk oo system: >punk . poses -invalidoption) - incr call_level -1 - if {[catch { - set nextup [tcl::info::frame $call_level] - } ]} { - break - } - set cmdinfo [tcl::dict::get $nextup cmd] - set caller [regexp -inline {\S+} $cmdinfo] - if {[interp alias {} $caller] ne ""} { - #puts "found alias for caller $caller to [interp alias {} $caller]" - #see if we can go further - incr call_level -1 - if {[catch { - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - } errM ]} { - puts "err: $errM" - break - } - } - } - set caller [regexp -inline {\S+} $cmdinfo] - if {$caller eq "namespace"} { - # review - message? - set cmdinfo "punk::args::get_dict called from namespace" - } - return $cmdinfo - } - - - # -------------------------------------- - #test of Get_caller - lappend PUNKARGS [list { - @id -id ::punk::args::test1 - @values -min 0 -max 0 - }] - proc test_get_dict {args} { - punk::args::get_dict {*}[punk::args::raw_def ::punk::args::test1] $args - } - proc test_get_by_id {args} { - punk::args::get_by_id ::punk::args::test1 $args - } - #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. - proc test_callers {args} { - if {![llength $args]} { - puts "these test functions accept no arguments" - puts "Call with arg(s) to compare error output" - } - - if {[catch {test_get_dict {*}$args} errM]} { - puts $errM - } - puts "------------" - if {[catch {test_get_by_id {*}$args} errM]} { - puts $errM - } - return done - } - # -------------------------------------- - - set map "" - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::arg_error - @cmd -name punk::args::arg_error -help\ - "Generates a table (by default) of usage information for a command. - A trie system is used to create highlighted prefixes for command - switches and for subcommands or argument/switch values that accept - a defined set of choices. These prefixes match the mechanism used - to validate arguments (based on tcl::prefix::match). - - This function is called during the argument parsing process - (if the definition is not only being used for documentation) - It is also called by punk::args::usage which is in turn - called by the punk::ns introspection facilities which creates - on the fly definitions for some commands such as ensembles and - oo objects where a manually defined one isn't present. - " - @leaders -min 2 -max 2 - msg -type string -help\ - "Error message to display immediately prior to usage table. - May be empty string to just display usage. - " - spec_dict -type dict -help\ - "Dictionary of argument specifications. - This is the internal format parsed from - the textual definition. It contains the data - organised/optimised to allow the final arg - parser/validator to make decisions. - " - @opts - -badarg -type string -help\ - "name of an argument to highlight" - -aserror -type boolean -help\ - "If true, the usage table is raised as an error message, - otherwise it is returned as a value." - -return -choices {string table tableobject} -choicelabels { - string "no table layout" - tableobject "table object cmd" - table "full table laout" - } - -scheme -choices {nocolour info error} - }] ] - - #basic recursion blocker - variable arg_error_isrunning 0 - proc arg_error {msg spec_dict args} { - #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. - #accept an option here so that we can still use full output for usage requests. - #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args - #Development/experimentation may be done with full table-based error reporting - but for production release it - #may be desirable to reduce overhead on catches. - #consider per-namespace or namespace-tree configurability. - #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due - #to resource availability etc - so the slower error generation time may not always be a problem. - #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling - #code which has no use for the enhanced error info. - #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. - #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system - #todo - #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error - #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) - - #todo - document unnamed leaders and unnamed values where -min and/or -max specified - #e.g punk::args::get_dict {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} {} - #only |?-x?|string|... is shown in the output table. - #should be something like: - # |arg | - # |?-x? | - # |arg | - # |?arg...?| - # Where/how to specify counts? - #also.. - # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? - # - - - if {[catch {package require punk::ansi}]} { - proc punk::args::a {args} {} - proc punk::args::a+ {args} {} - } else { - namespace eval ::punk::args { - namespace import ::punk::ansi::a ::punk::ansi::a+ - } - } - #limit colours to standard 16 so that themes can apply to help output - variable arg_error_isrunning - if {$arg_error_isrunning} { - error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" - } - - if {[llength $args] %2 != 0} { - error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" - } - - set arg_error_isrunning 1 - - set badarg "" - set returntype table ;#table as string - set as_error 1 ;#usual case is to raise an error - set scheme error - dict for {k v} $args { - set fullk [tcl::prefix::match -error "" {-badarg -aserror -return -scheme} $k] - switch -- $fullk { - -badarg { - set badarg $v - } - -aserror { - if {![string is boolean -strict $v]} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" - } - set as_error $v - } - -scheme { - set scheme $v - } - -return { - if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" - } - set returntype $v - } - default { - set arg_error_isrunning 0 - error "arg_error invalid option $k. Known_options: -badarg -return -aserror" - } - } - } - #todo - scheme - use config and iterm toml definitions etc - switch -- $scheme { - "" - -nocolor - -nocolour { - set scheme nocolour - } - info - error {} - default { - set scheme na - } - } - #hack some basics for now. - #for coloured schemes - use bold as well as brightcolour in case colour off. - array set CLR {} - set CLR(errormsg) [a+ brightred] - set CLR(title) "" - set CLR(check) [a+ brightgreen] - set CLR(solo) [a+ brightcyan] - set CLR(choiceprefix) [a+ underline] - set CLR(badarg) [a+ brightred] - set CLR(linebase_header) [a+ white] - set CLR(cmdname) [a+ brightwhite] - set CLR(groupname) [a+ bold] - set CLR(ansiborder) [a+ bold] - set CLR(ansibase_header) [a+ bold] - set CLR(ansibase_body) [a+ white] - - switch -- $scheme { - nocolour { - set CLR(errormsg) [a+ bold] - set CLR(title) [a+ bold] - set CLR(check) "" - set CLR(solo) "" - set CLR(badarg) [a+ reverse] ;#? experiment - set CLR(cmdname) [a+ bold] - set CLR(linebase_header) "" - set CLR(linebase) "" - set CLR(ansibase_body) "" - } - info { - set CLR(errormsg) [a+ brightred bold] - set CLR(title) [a+ brightyellow bold] - set CLR(check) [a+ brightgreen bold] - set CLR(choiceprefix) [a+ brightgreen bold] - set CLR(groupname) [a+ cyan bold] - set CLR(ansiborder) [a+ brightcyan bold] - set CLR(ansibase_header) [a+ cyan] - set CLR(ansibase_body) [a+ white] - } - error { - set CLR(errormsg) [a+ brightred bold] - set CLR(title) [a+ brightcyan bold] - set CLR(check) [a+ brightgreen bold] - set CLR(choiceprefix) [a+ brightgreen bold] - set CLR(groupname) [a+ cyan bold] - set CLR(ansiborder) [a+ brightyellow bold] - set CLR(ansibase_header) [a+ yellow] - set CLR(ansibase_body) [a+ white] - } - na { - } - } - - - #set RST [a] - set RST "\x1b\[m" - set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. - - #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error - #e.g list_as_table - - # use basic colours here to support terminals without extended colours - #todo - add checks column (e.g -minsize -maxsize) - set errmsg $msg - if {![catch {package require textblock}]} { - set has_textblock 1 - } else { - set has_textblock 0 - #couldn't load textblock package - #just return the original errmsg without formatting - } - set use_table 0 - if {$has_textblock && $returntype in {table tableobject}} { - set use_table 1 - } - set errlines [list] ;#for non-textblock output - if {[catch { - if {$use_table} { - append errmsg \n - } else { - if {($returntype in {table tableobject}) && !$has_textblock} { - append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n - } else { - append errmsg \n - } - } - set cmdname [Dict_getdef $spec_dict cmd_info -name ""] - set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] - - set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] - set docurl [Dict_getdef $spec_dict doc_info -url ""] - - set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] - set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] - if {"$argdisplay_header$argdisplay_body" eq ""} { - set is_custom_argdisplay 0 - } else { - set is_custom_argdisplay 1 - } - - - set blank_header_col [list] - if {$cmdname ne ""} { - lappend blank_header_col "" - set cmdname_display $CLR(cmdname)$cmdname$RST - } else { - set cmdname_display "" - } - if {$cmdhelp ne ""} { - lappend blank_header_col "" - #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] - set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] - } else { - set cmdhelp_display "" - } - if {$docurl ne ""} { - lappend blank_header_col "" - set docurl_display [a+ white]$docurl$RST - } else { - set docurl_display "" - } - #synopsis - set synopsis "" - set form_info [dict get $spec_dict FORM_INFO] - dict for {fid finfo} $form_info { - set syn [Dict_getdef $finfo -synopsis ""] - if {$syn ne ""} { - append synopsis $syn \n - } - } - if {$synopsis ne ""} { - set synopsis [string range $synopsis 0 end-1] - lappend blank_header_col "" - } - - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - if {$use_table} { - set t [textblock::class::table new "$CLR(title)Usage$RST"] - $t add_column -headers $blank_header_col -minwidth 3 - $t add_column -headers $blank_header_col - - if {!$is_custom_argdisplay} { - lappend blank_header_col "" - #spanned columns in default argdisplay area - $t add_column -headers $blank_header_col ;#Default - $t add_column -headers $blank_header_col ;#Multi - $t add_column -headers $blank_header_col ;#Help - set arg_colspans {1 4 0 0 0} - } else { - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - set arg_colspans {1 1} - } - } - set h 0 - if {$cmdname ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] - } else { - lappend errlines "COMMAND: $cmdname_display" - } - incr h - } - if {$cmdhelp ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] - } else { - lappend errlines "Description: $cmdhelp_display" - } - incr h - } - if {$docurl ne ""} { - if {![catch {package require punk::ansi}]} { - set docurl [punk::ansi::hyperlink $docurl] - } - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] - } else { - lappend errlines "$docname $docurl_display" - } - incr h - } - if {$synopsis ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Synopsis: $synopsis] - } else { - #todo - lappend errlines "Synopsis:\n$synopsis" - } - incr h - } - - - if {$use_table} { - if {$is_custom_argdisplay} { - if {$argdisplay_header ne ""} { - $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] - } - } else { - $t configure_header $h -values {Arg Type Default Multi Help} - } - } else { - lappend errlines " --ARGUMENTS-- " - } - - if {$is_custom_argdisplay} { - if {$use_table} { - #using overall container table - #header already added - #TODO - review textblock::table features - #we can't currently span columns within the table body. - #This feature could allow hidden data columns (and sort on hidden col?) - #potentially require coordination with header colspans? - $t add_row [list "" $argdisplay_body] - } else { - if {$argdisplay_header ne ""} { - lappend errlines $argdisplay_header - } - lappend errlines {*}$argdisplay_body - } - } else { - - #set A_DEFAULT [a+ brightwhite Brightgreen] - set A_DEFAULT "" - set A_BADARG $CLR(badarg) - set greencheck $CLR(check)\u2713$RST ;#green tick - set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply - if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { - #A_PREFIX can resolve to empty string if colour off - #we then want to display underline instead - set A_PREFIX [a+ underline] - set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space - } else { - set A_PREFIXEND $RST - } - - set opt_names [list] - set opt_names_display [list] - if {[llength [dict get $spec_dict OPT_NAMES]]} { - if {![catch {package require punk::trie}]} { - set trie [punk::trie::trieclass new {*}[dict get $spec_dict OPT_NAMES]] - set idents [dict get [$trie shortest_idents ""] scanned] - #todo - check opt_prefixdeny - - $trie destroy - foreach c [dict get $spec_dict OPT_NAMES] { - set id [dict get $idents $c] - #REVIEW - if {$id eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $id] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail - #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] - lappend opt_names $c - } - } else { - set opt_names [dict get $spec_dict OPT_NAMES] - set opt_names_display $opt_names - } - } - set leading_val_names [dict get $spec_dict LEADER_NAMES] - set trailing_val_names [dict get $spec_dict VAL_NAMES] - - #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { - # if {![string match -* $argname]} { - # lappend leading_val_names [lpop trailing_val_names 0] - # } else { - # break - # } - #} - #if {![llength $leading_val_names] && ![llength $opt_names]} { - # #all vals were actually trailing - no opts - # set trailing_val_names $leading_val_names - # set leading_val_names {} - #} - set leading_val_names_display $leading_val_names - set trailing_val_names_display $trailing_val_names - - #display options first then values - foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { - lassign $argumentset argnames_display argnames - - foreach argshow $argnames_display arg $argnames { - set arginfo [dict get $spec_dict ARG_INFO $arg] - if {[dict exists $arginfo -default]} { - set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" - } else { - set default "" - } - set help [Dict_getdef $arginfo -help ""] - set allchoices_originalcase [list] - set choices [Dict_getdef $arginfo -choices {}] - set choicegroups [Dict_getdef $arginfo -choicegroups {}] - set choicemultiple [dict get $arginfo -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] - set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] - if {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - set is_multiple 1 - } else { - set multiple "" - set is_multiple 0 - } - if {[dict exists $choicegroups ""]} { - dict lappend choicegroups "" {*}$choices - } else { - set choicegroups [dict merge [dict create "" $choices] $choicegroups] - } - dict for {groupname clist} $choicegroups { - lappend allchoices_originalcase {*}$clist - } - set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] - - if {$has_choices} { - if {$help ne ""} {append help \n} - if {[dict get $arginfo -nocase]} { - set casemsg " (case insensitive)" - set allchoices_test [string tolower $allchoices_originalcase] - } else { - set casemsg " (case sensitive)" - set allchoices_test $allchoices_originalcase - } - if {[dict get $arginfo -choiceprefix]} { - set prefixmsg " (choice prefix allowed)" - } else { - set prefixmsg "" - } - set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] - set formattedchoices [dict create] ;#use dict rather than array to preserve order - append help " Choices$prefixmsg$casemsg" - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - if {$choicemultiple_max == -1} { - append help \n " The value can be a list of $choicemultiple_min or more of these choices" - } else { - if {$choicemultiple_min eq $choicemultiple_max} { - append help \n " The value must be a list of $choicemultiple_min of these choices" - } else { - append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" - } - } - } - if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set cdisplay $c - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - dict lappend formattedchoices $groupname $cdisplay - } - } - } else { - set formattedchoices $choicegroups - #set formattedchoices [dict get $arginfo -choices] - } - } else { - if {[catch { - set trie [punk::trie::trieclass new {*}$allchoices_test] - set idents [dict get [$trie shortest_idents ""] scanned] - if {[dict get $arginfo -nocase]} { - #idents were calculated on lcase - remap keys in idents to original casing - set actual_idents $idents - foreach ch $allchoices_originalcase { - if {![dict exists $idents $ch]} { - #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting - #The actual testing is done in get_dict - dict set actual_idents $ch [dict get $idents [string tolower $ch]] - } - } - set idents $actual_idents - #puts "-----" - #puts "idents $idents" - } - - $trie destroy - dict for {groupname clist} $choicegroups { - foreach c $clist { - if {$c in $choiceprefixdenylist} { - set shortestid $c - } else { - set shortestid [dict get $idents $c] - } - if {$shortestid eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $shortestid] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]" - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - dict lappend formattedchoices $groupname $cdisplay - } - } - } errM]} { - #this failure can happen if -nocase is true and there are ambiguous entries - #e.g -nocase 1 -choices {x X} - puts stderr "prefix marking failed\n$errM" - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set cdisplay $c - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - dict lappend formattedchoices $groupname $cdisplay - } - } - } else { - set formattedchoices $choicegroups - } - - } - } - set choicetable_objects [list] - set choicetable_footers [dict create] - dict for {groupname formatted} $formattedchoices { - set numcols $choicecolumns ;#todo - dynamic? - if {[llength $formatted] < $numcols} { - #don't show blank cells if single line of results - set numcols [llength $formatted] - } - if {$numcols > 0} { - if {$use_table} { - #risk of recursing - #TODO -title directly in list_as_table - set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] - lappend choicetable_objects $choicetableobj - $choicetableobj configure -title $CLR(groupname)$groupname - #append help \n[textblock::join -- " " [$choicetableobj print]] - } else { - if {$groupname ne ""} { - append help \n \n "$CLR(groupname)Group: $groupname$RST" - } else { - append help \n - } - append help \n [join $formatted \n] - } - } else { - #we were given an empty set of choices. - #probably an error in the definition - but could happen if dynamically generated. - #(e.g ensemble where unknown mechanism is used for subcommands?) - #better to just display that there were none rather than totally break the usage output. - if {$usetable} { - #these will be displayed after all table entries - if {$groupname eq ""} { - dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" - } else { - dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" - } - } else { - if {$groupname eq ""} { - append help \n " " $CLR(errormsg)(no choices defined)$RST - } else { - append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST - } - } - } - } - set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width - foreach obj $choicetable_objects { - dict lappend twidths_by_colcount [$obj column_count] [$obj width] - } - foreach obj $choicetable_objects { - set cols [$obj column_count] - set widths [dict get $twidths_by_colcount $cols] - set max [tcl::mathfunc::max {*}$widths] - $obj configure -minwidth $max ;#expand smaller ones - set i 0 - while {$i < $cols} { - #keep text aligned left on expanded tables - $obj configure_column $i -blockalign left - incr i - } - - append help \n[textblock::join -- " " [$obj print]] - #set ansititle [dict get [$obj configure -title] value] - $obj destroy - } - if {[dict size $choicetable_footers]} { - foreach groupname [dict keys $formattedchoices] { - if {[dict exists $choicetable_footers $groupname]} { - append help \n [dict get $choicetable_footers $groupname] - } - } - } - - #review. use -type to restrict additional choices - may be different to values in the -choices - if {![dict get $arginfo -choicerestricted]} { - #when -choicemultiple - the -type refers to each selection - if {[dict get $arginfo -type] eq "string"} { - append help "\n (values not in defined choices are allowed)" - } else { - append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" - } - } - } - if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { - if {$is_multiple} { - set argshow "?${argshow}...?" - } else { - set argshow "?${argshow}?" - } - } else { - if {$is_multiple} { - set argshow "${argshow}..." - } - } - set typeshow [dict get $arginfo -type] - if {$typeshow eq "none"} { - set typeshow "$typeshow $soloflag" - } - if {[dict exists $arginfo -minsize]} { - append typeshow \n "-minsize [dict get $arginfo -minsize]" - } - if {[dict exists $arginfo -maxsize]} { - append typeshow \n "-maxsize [dict get $arginfo -maxsize]" - } - if {[dict exists $arginfo -range]} { - append typeshow \n "-range [dict get $arginfo -range]" - } - - if {$use_table} { - $t add_row [list $argshow $typeshow $default $multiple $help] - if {$arg eq $badarg} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG - } - } else { - #review - formatting will be all over the shop due to newlines in typesshow, help - set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" - foreach ln [split $help \n] { - append arghelp " $ln" \n - } - lappend errlines $arghelp - } - } - } - } ;#end is_custom_argdisplay - - if {$use_table} { - $t configure -show_hseps 0\ - -show_header 1\ - -ansibase_body $CLR(ansibase_body)\ - -ansibase_header $CLR(ansibase_header)\ - -ansiborder_header $CLR(ansiborder)\ - -ansiborder_body $CLR(ansiborder) - - $t configure -maxwidth 80 ;#review - if {$returntype ne "tableobject"} { - append errmsg [$t print] - #returntype of table means just the text of the table - $t destroy - } - } else { - append errmsg [join $errlines \n] - } - } errM]} { - catch {$t destroy} - append errmsg \n - append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n - append errmsg "$errM" \n - append errmsg "$::errorInfo" - - } - set arg_error_isrunning 0 - #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. - #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) - if {$use_table} { - #assert returntype is one of table, tableobject - set result $errmsg ;#default if for some reason table couldn't be used - if {$returntype eq "tableobject"} { - if {[info object isa object $t]} { - set result $t - } - } - } else { - set result $errmsg - } - if {$as_error} { - return -code error -errorcode {TCL WRONGARGS PUNK} $result - } else { - return $result - } - } - - - lappend PUNKARGS [list { - @dynamic - @id -id ::punk::args::usage - @cmd -name punk::args::usage -help\ - "Return usage information for a command identified by an id. - - This will only work for commands where a punk::args definition exists - for the command and an id has been defined for it. The id for custom - help for a command should match the fully qualified name of the command. - - Many commands (such as ensembles and oo objects) may have argument - documentation generated dynamically and may not yet have an id. - IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. - - Generally punk::ns::arginfo (aliased as i in the punk shell) should - be used in preference - as it will search for a documentation - mechanism and call punk::args::usage as necessary. - " - -return -default table -choices {string table tableobject} - } {${[punk::args::resolved_def -types opts ::punk::args::arg_error -scheme]}} { - - @values -min 0 -max 1 - id -help\ - "Exact id. - Will usually match the command name" - }] - proc usage {args} { - lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received - set id [dict get $values id] - set real_id [real_id $id] - if {$real_id eq ""} { - error "punk::args::usage - no such id: $id" - } - arg_error "" [punk::args::get_spec $real_id] -scheme punk_info {*}$opts -aserror 0 - } - - lappend PUNKARGS [list { - @id -id ::punk::args::get_by_id - @cmd -name punk::args::get_by_id - @values -min 1 - id - arglist -type list -help\ - "list containing arguments to be parsed as per the - argument specification identified by the supplied id." - }] - - - #deprecate? - proc get_by_id {id arglist} { - set definitionlist [punk::args::raw_def $id] - if {[llength $definitionlist] == 0} { - error "punk::args::get_by_id - no such id: $id" - } - #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] - tailcall ::punk::args::get_dict {*}$definitionlist $arglist - } - - #consider - - #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) - #parse ?-flag val?... -- $arglist withid $id - #parse ?-flag val?... -- $arglist withdef $def ?$def?... - - #an experiment.. ideally we'd like arglist at the end? - #parse_withid ?-flag val?.. $id $arglist - #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? - #no possible equivalent for parse_withdef ??? - - lappend PUNKARGS [list { - @id -id ::punk::args::parse - @cmd -name punk::args::parse -help\ - "parse and validate command arguments based on a definition. - - In the 'withid' form the definition is a pre-existing record that has been - created with ::punk::args::define, or indirectly by adding a definition to - the PUNKARGS variable in a namespace which is then registered in - punk::args::register::NAMESPACES, or by a previous call to punk::parse - using 'withdef' and a definition block containing an @id -id directive. - - In the 'withdef' form - the definition is created on the first call and - cached thereafter, if the id didn't already exist. - - form1: parse $arglist ?-flag val?... withid $id - form2: parse $arglist ?-flag val?... withdef $def ?$def? - see punk::args::define" - @form -form {withid withdef} - @leaders -min 1 -max 1 - arglist -type list -optional 0 -help\ - "Arguments to parse - supplied as a single list" - - @opts - -form -type list -default * -help\ - "Restrict parsing to the set of forms listed. - Forms are the orthogonal sets of arguments a - command can take - usually described in 'synopsis' - entries." - #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance - #todo - configurable per interp/namespace - -errorstyle -type string -default enhanced -choices {enhanced standard minimal} - - @values -min 2 - - @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" - withid -type literal -help\ - "The literal value 'withid'" - id -type string -help\ - "id of punk::args definition for a command" - - - @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" - withdef -type literal -help\ - "The literal value 'withdef'" - - #todo - make -dynamic obsolete - use @dynamic directive instead - def -type string -multiple 1 -optional 0 -help\ - "Each remaining argument is a block of text - defining argument definitions. - As a special case, -dynamic may be - specified as the 1st 2 arguments. These are - treated as an indicator to punk::args about - how to process the definition." - - }] - proc parse {args} { - set tailtype "" ;#withid|withdef - if {[llength $args] < 3} { - error "punk::args::parse - invalid call. < 3 args" - } - set parseargs [lindex $args 0] - set tailargs [lrange $args 1 end] - - set split [lsearch -exact $tailargs withid] - if {$split < 0} { - set split [lsearch -exact $tailargs withdef] - if {$split < 0} { - #punk::args::usage arg_error? - error "punk::args::parse - invalid call. keyword withid|withdef required" - } else { - set tailtype withdef - } - } else { - set tailtype withid - } - - set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. - if {[llength $opts] % 2} { - error "punk::args::parse Even number of -flag val pairs required after arglist" - } - set defaultopts [dict create\ - -form {*}\ - -errorstyle enhanced\ - ] - set opts [dict merge $opts $defaultopts] - dict for {k v} $opts { - switch -- $k { - -form - -errorstyle { - } - default { - #punk::args::usage $args withid ::punk::args::parse ?? - error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" - } - } - } - switch -- $tailtype { - withid { - if {[llength [lrange $tailargs $split+1 end]] != 1} { - error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - } - set id [lindex $tailargs $split+1] - #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" - set deflist [raw_def $id] - if {[llength $deflist] == 0} { - error "punk::args::parse - no such id: $id" - } - } - withdef { - set deflist [lrange $tailargs $split+1 end] - if {[llength $deflist] < 1} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" - } - default { - error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" - } - } - try { - set result [punk::args::get_dict {*}$deflist $parseargs] - } trap {PUNKARGS} {msg opts} { - #trap punk::args argument validation/parsing errors and decide here - #whether to display basic error - or full usage if configured. - puts stderr "PUNKARGS: $msg\n$opts" - return - } trap {} {msg opts} { - #review - #puts stderr "$msg\n$opts" - #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. - #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. - throw [dict get $opts -errorcode] [dict get $opts -errorinfo] - return - } - return $result - } - proc parseXXX {args} { - #no solo flags allowed for parse function itself. (ok for arglist being parsed) - set opts [dict create] ;#repeated flags will override earlier. That's ok here. - set arglist {} - set got_arglist 0 - set tailtype "" ;#withid|withdef - set id "" - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {[string match -* $a]} { - dict set opts $a [lindex $args $i+1] - incr i - } else { - set arglist $a - set got_arglist 1 - set tailtype [lindex $args $i+1] - if {$tailtype eq "withid"} { - if {[llength $args] != $i+3} { - error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - } - set id [lindex $args $i+2] - break - } elseif {$tailtype eq "withdef"} { - if {[llength $args] < $i+3} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - set deflist [lrange $args $i+2 end] - break - } else { - error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" - } - } - } - if {!$got_arglist} { - error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." - } - #assert tailtype eq withid|withdef - if {$tailtype eq "withid"} { - #assert $id was provided - return "parse [llength $arglist] args withid $id, options:$opts" - } else { - #assert llength deflist >=1 - return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" - } - #TODO - } - - #todo? - a version of get_dict that directly supports punk::lib::tstr templating - #rename get_dict - # - - #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 get_dict {args} { - #see arg_error regarding considerations around unhappy-path performance - - #consider a better API - # - e.g punk::args::parse ?-flag val?... $arglist withid $id - # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? - #can the above be made completely unambiguous for arbitrary arglist?? - #e.g what if arglist = withdef and the first $def is also withdef ? - - - #*** !doctools - #[call [fun get_dict] [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 values - #[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 defining a flag 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 - #[para]Each optionspec line defining a positional argument is of the form: - #[para]argumentname -key val -ky2 val2... - #[para]where the valid keys for each option specification are: -default -type -range -choices - #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value - #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. - #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. - #[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, - #but it could be a manually constructed list of values made for example from positional args defined in the proc. - #[list_end] - #[para] - - #consider line-processing example below for which we need info complete to determine record boundaries - #punk::args::get_dict { - # @opts - # -opt1 -default {} - # -opt2 -default { - # etc - # } - # @values -multiple 1 - #} $args - - set rawargs [lindex $args end] ;# args values to be parsed - #we take a definition list rather than argspecs - because the definition could be dynamic - set definition_args [lrange $args 0 end-1] - - #if definition has been seen before, - #define will either return a permanently cached argspecs (-dynamic 0) - or - # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. - set argspecs [uplevel 1 [list ::punk::args::resolve {*}$definition_args]] - - # ----------------------------------------------- - # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) - tcl::dict::with argspecs {} ;#turn keys into vars - # TODO - capitalise 'define' vars to make it a bit easier - # ----------------------------------------------- - - #puts "-arg_info->$arg_info" - set flagsreceived [list] ;#for checking if required flags satisfied - #secondary purpose: - #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 ? - - # -- --- --- --- - # Handle leading positionals - # todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ? - set opts $opt_defaults - set pre_values {} - - set argnames [tcl::dict::keys $ARG_INFO] - set optnames [lsearch -all -inline $argnames -*] - set ridx 0 - set rawargs_copy $rawargs - set leader_posn_name "" - set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) - set is_multiple 0 ;#last leader may be multi - if {$LEADER_MAX != 0} { - foreach r $rawargs_copy { - if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { - break - } - if {$ridx == [llength $LEADER_NAMES]-1} { - #at last named leader - set leader_posn_name [lindex $LEADER_NAMES $ridx] - if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { - set is_multiple 1 - } - } elseif {$ridx > [llength $LEADER_NAMES]-1} { - #beyond names - retain name if -multiple was true - if {!$is_multiple} { - set leader_posn_name "" - } - } else { - set leader_posn_name [lindex $LEADER_NAMES $ridx] ;#may return empty string - } - if {$r eq "--"} { - #review end of opts marker: '--' can't be a leader (but can be a value) - break - } - - #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option - if {[tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { - set matchopt [::tcl::prefix::match -error {} $optnames $r] - if {$matchopt ne ""} { - #flaglike matches a known flag - don't treat as leader - break - } - #if {![string match -* [lindex $argnames $ridx]]} {} - if {$leader_posn_name ne ""} { - #there is a named leading positional for this position - #The flaglooking value doesn't match an option - so treat as a leader - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - incr ridx - continue - } else { - break - } - } - - #for each branch - break or lappend - if {$leader_posn_name ne ""} { - if {$leader_posn_name ni $LEADER_REQUIRED} { - #optional leader - - #most adhoc arg processing will allocate based on number of args rather than matching choice values first - #(because a choice value could be a legitimate data value) - - #review - option to process in this manner? - #first check if the optional leader value is a match for a choice ? - #if {[dict exists $arg_info $leader_posn_name -choices]} { - # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] [lindex $rawargs 0]] - # if {$vmatch ne ""} { - # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values - # lappend pre_values [lpop rawargs 0] - # incr ridx - # continue - # } - #} - - #check if enough rawargs to fill any required values - if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { - break - } else { - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #required - if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { - #already accepted at least one value - requirement satisfied - now equivalent to optional - if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { - break - } - } - #if we didn't break - requirement is not yet satisfied, or is satisfied but stil enough rawargs for required values - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #unnamed leader - if {$LEADER_MIN ne "" } { - if {$ridx > $LEADER_MIN} { - break - } else { - #haven't reached LEADER_MIN - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - break - } - } - - incr ridx - } ;# end foreach r $rawargs_copy - } - - set argstate $ARG_INFO ;#argstate may have entries added - set arg_checks $ARG_CHECKS - - if {$LEADER_MIN eq ""} { - set leadermin 0 - } else { - set leadermin $LEADER_MIN - } - if {$LEADER_MAX eq ""} { - set leadermax -1 - } else { - set leadermax $LEADER_MAX - } - - #assert leadermax leadermin are numeric - #assert - rawargs has been reduced by leading positionals - - set leaders [list] - set arglist {} - set post_values {} - #val_min, val_max - #puts stderr "rawargs: $rawargs" - #puts stderr "argstate: $argstate" - if {[lsearch $rawargs -*] >= 0} { - #at least contains flaglike things.. - set maxidx [expr {[llength $rawargs] -1}] - if {$val_max == -1} { - set vals_total_possible [llength $rawargs] - set vals_remaining_possible $vals_total_possible - } else { - set vals_total_possible $val_max - set vals_remaining_possible $vals_total_possible - } - for {set i 0} {$i <= $maxidx} {incr i} { - set a [lindex $rawargs $i] - set remaining_args_including_this [expr {[llength $rawargs] - $i}] - #lowest val_min is 0 - if {$remaining_args_including_this <= $val_min} { - # if current arg is -- it will pass through as a value here - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - - #exlude argument with whitespace from being a possible option e.g dict - if {[tcl::string::match -* $a] && !([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { - if {$a eq "--"} { - #remaining num args <= val_min already covered above - if {$val_max != -1} { - #finite max number of vals - if {$remaining_args_including_this == $val_max} { - #assume it's a value. - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - } else { - #assume it's an end-of-options marker - lappend flagsreceived -- - set arglist [lrange $rawargs 0 $i] - set post_values [lrange $rawargs $i+1 end] - } - } else { - #unlimited number of post_values accepted - #treat this as eopts - we don't care if remainder look like options or not - lappend flagsreceived -- - set arglist [lrange $rawargs 0 $i] - set post_values [lrange $rawargs $i+1 end] - } - break - } else { - set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] - if {$fullopt ne ""} { - if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { - #non-solo - #check if it was actually a value that looked like a flag - if {$i == $maxidx} { - #if no optvalue following - assume it's a value - #(caller should probably have used -- before it) - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - - set flagval [lindex $rawargs $i+1] - if {[tcl::dict::get $argstate $fullopt -multiple]} { - #don't lappend to default - we need to replace if there is a default - if {$fullopt ni $flagsreceived} { - tcl::dict::set opts $fullopt [list $flagval] - } else { - tcl::dict::lappend opts $fullopt $flagval - } - } else { - tcl::dict::set opts $fullopt $flagval - } - #incr i to skip flagval - incr vals_remaining_possible -2 - if {[incr i] > $maxidx} { - arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $fullopt - } - } else { - #solo - if {[tcl::dict::get $argstate $fullopt -multiple]} { - if {$fullopt ni $flagsreceived} { - #override any default - don't lappend to it - tcl::dict::set opts $fullopt 1 - } else { - tcl::dict::lappend opts $fullopt 1 - } - } else { - tcl::dict::set opts $fullopt 1 - } - incr vals_remaining_possible -1 - } - lappend flagsreceived $fullopt ;#dups ok - } else { - #unmatched option flag - #comparison to val_min already done above - if {$val_max ne -1 && $remaining_args_including_this <= $val_max} { - #todo - look at optspec_default and see if solo/vs opt-val pair - #we may need to lookahead by 2 regarding val_max val_min - - #even with optany - assume an unknown within the space of possible values is a value - #unmatched option in right position to be considered a value - treat like eopts - #review - document that an unspecified arg within range of possible values will act like eopts -- - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - if {$opt_any} { - set newval [lindex $rawargs $i+1] - #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option - tcl::dict::set argstate $a $optspec_defaults ;#use default settings for unspecified opt - tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS - if {[tcl::dict::get $argstate $a -type] ne "none"} { - if {[tcl::dict::get $argstate $a -multiple]} { - tcl::dict::lappend opts $a $newval - } else { - tcl::dict::set opts $a $newval - } - if {[incr i] > $maxidx} { - arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a - } - incr vals_remaining_possible -2 - } else { - #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none - if {[tcl::dict::get $argstate $a -multiple]} { - if {![tcl::dict::exists $opts $a]} { - tcl::dict::set opts $a 1 - } else { - tcl::dict::lappend opts $a 1 - } - } else { - tcl::dict::set opts $a 1 - } - incr vals_remaining_possible -1 - } - lappend flagsreceived $a ;#adhoc flag as supplied - } else { - if {[llength $OPT_NAMES]} { - set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $OPT_NAMES" - } else { - set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": No options defined while @opts -any 0" - } - arg_error $errmsg $argspecs -badarg $fullopt - } - } - } - } else { - #not flaglike - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - } - #set values [list {*}$pre_values {*}$post_values] - set leaders $pre_values - set values $post_values - } else { - set leaders $pre_values - set values $rawargs - #set values [list {*}$pre_values {*}$rawargs] ;#no -flags detected - set arglist [list] - } - #puts stderr "--> arglist: $arglist" - #puts stderr "--> values: $values" - - - set positionalidx 0 ;#index for unnamed positionals (both leaders and values) - set ldridx 0 - set in_multiple "" - set leadernames_received [list] - set leaders_dict $LEADER_DEFAULTS - set num_leaders [llength $leaders] - foreach leadername $LEADER_NAMES ldr $leaders { - if {$ldridx+1 > $num_leaders} { - break - } - if {$leadername ne ""} { - if {[tcl::dict::get $argstate $leadername -multiple]} { - if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { - tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list - } else { - tcl::dict::lappend leaders_dict $leadername $ldr - } - set in_multiple $leadername - } else { - tcl::dict::set leaders_dict $leadername $ldr - } - lappend leadernames_received $leadername - } else { - if {$in_multiple ne ""} { - tcl::dict::lappend leaders_dict $in_multiple $ldr - lappend leadernames_received $in_multiple ;#deliberately allow dups! (as with opts and values) - } else { - tcl::dict::set leaders_dict $positionalidx $ldr - tcl::dict::set argstate $positionalidx $leaderspec_defaults - tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS - lappend leadernames_received $positionalidx - } - } - incr ldridx - incr positionalidx - } - - set validx 0 - set in_multiple "" - set valnames_received [list] - set values_dict $val_defaults - set num_values [llength $values] - foreach valname $VAL_NAMES val $values { - if {$validx+1 > $num_values} { - break - } - if {$valname ne ""} { - if {[tcl::dict::get $argstate $valname -multiple]} { - if {[tcl::dict::exists $val_defaults $valname]} { - #current stored val equals defined default - don't include default in the list we build up - tcl::dict::set values_dict $valname [list $val] ;#important to treat first element as a list - } else { - tcl::dict::lappend values_dict $valname $val - } - set in_multiple $valname - } else { - tcl::dict::set values_dict $valname $val - } - lappend valnames_received $valname - } else { - if {$in_multiple ne ""} { - tcl::dict::lappend values_dict $in_multiple $val - #name already seen - but must add to valnames_received anyway (as with opts and leaders) - lappend valnames_received $in_multiple - } else { - tcl::dict::set values_dict $positionalidx $val - tcl::dict::set argstate $positionalidx $valspec_defaults - tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS - lappend valnames_received $positionalidx - } - } - incr validx - incr positionalidx - } - - if {$leadermax == -1} { - #only check min - if {$num_leaders < $leadermin} { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leadermin" $argspecs - } - } else { - if {$num_leaders < $leadermin || $num_leaders > $leadermax} { - if {$leadermin == $leadermax} { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leadermin" $argspecs - } else { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" $argspecs - } - } - } - - if {$val_max == -1} { - #only check min - if {$num_values < $val_min} { - arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected at least $val_min" $argspecs - } - } else { - if {$num_values < $val_min || $num_values > $val_max} { - if {$val_min == $val_max} { - arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected exactly $val_min" $argspecs - } else { - arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected between $val_min and $val_max inclusive" $argspecs - } - } - } - - #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options - - - #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 SHOULD? 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 - - #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? - #example timing difference: - #struct::set difference {x} {a b} - #normal interp 0.18 u2 vs safe interp 9.4us - #if {[llength [set missing [struct::set difference $opt_required $flagsreceived]]]} { - # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" - #} - #if {[llength [set missing [struct::set difference $val_required $valnames_received]]]} { - # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" - #} - #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us - if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { - arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - if {[llength [set missing [punklib_ldiff $opt_required $flagsreceived]]]} { - arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs - } - if {[llength [set missing [punklib_ldiff $val_required $valnames_received]]]} { - arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - - - #todo - truncate/summarize values in error messages - - #todo - allow defaults outside of choices/ranges - - #check types,ranges,choices - set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] - #set combined_defaults [tcl::dict::merge $val_defaults $opt_defaults] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash - #puts "---opts_and_values:$opts_and_values" - #puts "---argstate:$argstate" - tcl::dict::for {argname v} $opts_and_values { - set thisarg [tcl::dict::get $argstate $argname] - #set thisarg_keys [tcl::dict::keys $thisarg] - set thisarg_checks [tcl::dict::get $arg_checks $argname] - set is_multiple [tcl::dict::get $thisarg -multiple] - set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] - set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] - set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] - set has_default [tcl::dict::exists $thisarg -default] - if {$has_default} { - set defaultval [tcl::dict::get $thisarg -default] - } - set type [tcl::dict::get $thisarg -type] - set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] - set regexprepass [tcl::dict::get $thisarg -regexprepass] - set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 - set validationtransform [tcl::dict::get $thisarg -validationtransform] - - - if {$is_multiple} { - set vlist $v - } else { - set vlist [list $v] - } - set vlist_original $vlist ;#retain for possible final strip_ansi - - #review - validationtransform - if {$is_validate_ansistripped} { - #validate_ansistripped 1 - package require punk::ansi - set vlist_check [list] - foreach e $vlist { - lappend vlist_check [punk::ansi::ansistrip $e] - } - } else { - #validate_ansistripped 0 - set vlist_check $vlist - } - - #reduce our validation requirements by removing values which match defaultval or match -choices - #(could be -multiple with -choicerestriction 0 where some selections match and others don't) - if {$has_choices} { - #-choices must also work with -multiple - #todo -choicelabels - set choiceprefix [tcl::dict::get $thisarg -choiceprefix] - set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] - set choicerestricted [tcl::dict::get $thisarg -choicerestricted] - set choicemultiple [tcl::dict::get $thisarg -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set nocase [tcl::dict::get $thisarg -nocase] - set choices [Dict_getdef $thisarg -choices {}] - set choicegroups [Dict_getdef $thisarg -choicegroups {}] - set allchoices $choices - if {[dict size $choicegroups]} { - dict for {groupname groupmembers} $choicegroups { - lappend allchoices {*}$groupmembers - } - } - #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups - #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes - - - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - set dname leaders_dict - } - option { - set dname opts - } - value { - set dname values_dict - } - } - set idx 0 ;# - #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes - #assert llength $vlist == llength [dict get $dname $argname] - # (unless there was a default and the option wasn't specified) - set vlist_validate [list] - set vlist_check_validate [list] - foreach e $vlist e_check $vlist_check { - set allchoices_in_list 0 - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - #vlist and vlist_check can be list of lists if -multiple and -choicemultiple - #each e represents 0 or more choice selections - set c_list $e - set c_check_list $e_check - #todo? check if entire list matches default? - } else { - #only one choice at a time - ensure single entry in c_list c_check_list - set c_list [list $e] - set c_check_list [list $e_check] - } - - - #----------------------------------- - #fast fail on the wrong number of choices - if {[llength $c_list] < $choicemultiple_min} { - set msg "Option $argname for [Get_caller] requires at least $choicemultiple_min choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { - set msg "Option $argname for [Get_caller] requires at most $choicemultiple_max choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - #----------------------------------- - - set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list - foreach c $c_list c_check $c_check_list { - if {$nocase} { - set casemsg " (case insensitive)" - set choices_test [tcl::string::tolower $allchoices] - #Don't lcase the denylist - even in nocase mode! - #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] - set v_test [tcl::string::tolower $c_check] - } else { - set casemsg " (case sensitive)" - set v_test $c_check - set choices_test $allchoices - } - set choice_in_list 0 - set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? - if {!$matches_default} { - if {$choiceprefix} { - #can we handle empty string as a choice? It should just work - REVIEW/test - set choice_exact_match 0 - if {$c_check in $allchoices} { - #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing - set chosen $c_check - set choice_in_list 1 - set choice_exact_match 1 - } elseif {$v_test in $choices_test} { - #assert - if we're here, nocase must be true - #we know choice is present as full-length match except for case - #now we want to select the case from the choice list - not the supplied value - #we don't set choice_exact_match - because we will need to override the optimistic existing val below - #review - foreach avail [lsort -unique $allchoices] { - if {[string match -nocase $c $avail]} { - set chosen $avail - } - } - #assert chosen will always get set - set choice_in_list 1 - } else { - #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. - #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. - #in this block we can treat empty result from prefix match as a non-match - if {$nocase} { - #nocase implies that our entered value doesn't have to match case of choices - - #but we would still like to select the best match if there are case-dups. - #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete - # selecting Del will find Delete, del will match delete (and raise error) - # but DEL will also match delete rather than Delete - so again an error is raised. - #This is counterintuitive with -nocase - #This is probably such an edge case that best served with documentation as a feature-not-bug - #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? - #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. - - set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] - if {$bestmatch eq ""} { - set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] - #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing - set chosen [lsearch -inline -nocase $allchoices $chosen] - set choice_in_list [expr {$chosen ne ""}] - } else { - set chosen $bestmatch - set choice_in_list 1 - } - } else { - set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] - if {$chosen eq ""} { - set choice_in_list 0 - } else { - set choice_in_list 1 - } - } - #override choice_in_list if in deny list - #don't allow prefixing for elements from -choiceprefixdenylist - #we still use all elements to calculate the prefixes though - #review - case difference edge cases in choiceprefixdenylist !todo - if {$chosen in $choiceprefixdenylist} { - set choice_in_list 0 - set chosen "" - } - } - - #override the optimistic existing val - if {$choice_in_list && !$choice_exact_match} { - if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { - if {$is_multiple} { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $idx $chosen - tcl::dict::set $dname $argname $existing - } else { - tcl::dict::set $dname $argname $chosen - } - } else { - if {$is_multiple} { - set existing_all [tcl::dict::get [set $dname] $argname] - lset existing_all $idx $choice_idx $chosen - tcl::dict::set $dname $argname $existing_all - } else { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $choice_idx $chosen - tcl::dict::set $dname $argname $existing - } - } - } - } else { - #value as stored in $dname is ok - set choice_in_list [expr {$v_test in $choices_test}] - } - } - - if {!$choice_in_list && !$matches_default} { - if {!$choicerestricted} { - #if {$is_multiple} { - # set existing [tcl::dict::get [set $dname] $argname] - # lset existing $idx $v_test - # tcl::dict::set $dname $argname $existing - #} else { - # tcl::dict::set $dname $argname $v_test - #} - lappend vlist_validate $c - lappend vlist_check_validate $c_check - } else { - #unhappy path - if {$choiceprefix} { - set prefixmsg " (or a unique prefix of a value)" - } else { - set prefixmsg "" - } - arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname - } - } - incr choice_idx - } - - incr idx - } - #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation - #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - - if {[llength $vlist] && $has_default} { - set vlist_validate [list] - set vlist_check_validate [list] - foreach c $vlist c_check $vlist_check { - #for -choicemultiple with default that could be a list use 'ni' ?? review - if {$c_check ne $defaultval} { - lappend vlist_validate $c - lappend vlist_check_validate $c - } - } - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - - #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups - #assert: our vlist & vlist_check lists have been reduced to remove those - if {[llength $vlist] && !$is_allow_ansi} { - #allow_ansi 0 - package require punk::ansi - #do not run ta::detect on a list - foreach e $vlist { - if {[punk::ansi::ta::detect $e]} { - error "Option $argname for [Get_caller] contains ansi - but -allow_ansi is false. Received: '$e'" - } - } - } - #puts "argname:$argname v:$v is_default:$is_default" - #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. - #arguments that are at their default are not subject to type and other checks - - #don't validate defaults or choices that matched - #puts "---> opts_and_values: $opts_and_values" - #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" - #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} - - #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups - #assert [llength $vlist] == [llength $vlist_check] - if {[llength $vlist]} { - 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 -badarg $argname - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[llength $e_check] < $checkval} { - arg_error "Option $argname for [Get_caller] requires list with -minsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[llength $e_check] > $checkval} { - arg_error "Option $argname for [Get_caller] requires list with -maxsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - } - } - } - } - } - } - string - ansistring - globstring { - #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string - #we possibly don't want to always have to regex on things that don't pass the other more basic checks - # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) - # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) - # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead - # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function - # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) - # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail - - #todo? - way to validate both unstripped and stripped? - set pass_quick_list_e [list] - set pass_quick_list_e_check [list] - set remaining_e $vlist - set remaining_e_check $vlist_check - #review - order of -regexprepass and -regexprefail in original rawargs significant? - #for now -regexprepass always takes precedence - if {$regexprepass ne ""} { - foreach e $vlist e_check $vlist_check { - if {[regexp $regexprepass $e]} { - lappend pass_quick_list_e $e - lappend pass_quick_list_e_check $e_check - } - } - set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] - set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] - } - if {$regexprefail ne ""} { - foreach e $remaining_e e_check $remaining_e_check { - #puts "----> checking $e vs regex $regexprefail" - if {[regexp $regexprefail $e]} { - if {[tcl::dict::exists $thisarg -regexprefailmsg]} { - set msg [tcl::dict::get $thisarg -regexprefailmsg] - } else { - set msg "Option $argname for [Get_caller] didn't pass regexprefail regex: '$regexprefail' got '$e'" - } - arg_error $msg $argspecs -badarg $argname - } - } - } - switch -- $type { - ansistring { - #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi - #.. so we need to look at the original values in $vlist not $vlist_check - - #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? - #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? - package require punk::ansi - foreach e $remaining_e { - if {![punk::ansi::ta::detect $e]} { - arg_error "Option $argname for [Get_caller] requires ansistring - but no ansi detected" $argspecs -badarg $argname - } - } - } - globstring { - foreach e $remaining_e { - if {![regexp {[*?\[\]]} $e]} { - arg_error "Option $argname for [Get_caller] requires globstring - but no glob characters detected" $argspecs -badarg $argname - } - } - } - } - - if {[tcl::dict::size $thisarg_checks]} { - foreach e_check $remaining_e_check { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[tcl::string::length $e_check] < $checkval} { - arg_error "Option $argname for [Get_caller] requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::string::length $e_check] > $checkval} { - arg_error "Option $argname for [Get_caller] requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - } - } - } - } - } - } - int { - #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive - if {[tcl::dict::exists $thisarg -range]} { - lassign [tcl::dict::get $thisarg -range] low high - if {"$low$high" ne ""} { - if {$low eq ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname - } - #lowside unspecified - check only high - if {$e_check > $high} { - arg_error "Option $argname for [Get_caller] must be integer less than or equal to $high. Received: '$e'" $argspecs -badarg $argname - } - } - } elseif {$high eq ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname - } - #highside unspecified - check only low - if {$e_check < $low} { - arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs -badarg $argname - } - } - } else { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname - } - #high and low specified - if {$e_check < $low || $e_check > $high} { - arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs -badarg $argname - } - } - } - } - } else { - foreach e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e_check'" $argspecs -badarg $argname - } - } - } - } - double { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is double -strict $e_check]} { - error "Option $argname for [Get_caller] requires type 'double'. Received: '$e'" - } - if {[tcl::dict::size $thisarg_checks]} { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -range { - #todo - small-value double comparisons with error-margin? review - #todo - empty string for low or high - lassign $checkval low high - if {$e_check < $low || $e_check > $high} { - arg_error "Option $argname for [Get_caller] must be between $low and $high. Received: '$e'" $argspecs -badarg $argname - } - } - } - } - } - } - } - bool { - foreach e_check $vlist_check { - if {![tcl::string::is boolean -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'boolean'. Received: '$e_check'" $argspecs -badarg $argname - } - } - } - dict { - foreach e_check $vlist_check { - 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 -badarg $argname - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -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 -minsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::dict::size $e_check] > $checkval} { - arg_error "Option $argname for [Get_caller] requires dict with -maxsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - } - } - } - } - } - } - alnum - - alpha - - ascii - - control - - digit - - graph - - lower - - print - - punct - - space - - upper - - wordchar - - xdigit { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is $type $e_check]} { - set msg "Option $argname for [Get_caller] requires type '$type'. Received: '$e'" - #try trap? - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type]]] $result - #throw ? - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname]] $msg - arg_error $msg $argspecs -badarg $argname - } - } - } - file - - directory - - existingfile - - existingdirectory { - foreach e $vlist e_check $vlist_check { - #//review - we may need '?' char on windows - if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { - #what about special file names e.g on windows NUL ? - arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" $argspecs -badarg $argname - } - } - if {$type eq "existingfile"} { - foreach e $vlist e_check $vlist_check { - if {![file exists $e_check]} { - arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing file" $argspecs -badarg $argname - } - } - } elseif {$type eq "existingdirectory"} { - foreach e $vlist e_check $vlist_check { - if {![file isdirectory $e_check]} { - arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing directory" $argspecs -badarg $argname - } - } - } - } - char { - foreach e $vlist e_check $vlist_check { - if {[tcl::string::length $e_check] != 1} { - arg_error "Option $argname for [Get_caller] requires type 'character'. Received: '$e' which is not a single character" $argspecs -badarg $argname - } - } - } - } - - } - - if {$is_strip_ansi} { - set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach - if {[tcl::dict::get $thisarg -multiple]} { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict $argname $stripped_list - } - option { - tcl::dict::set opts $argname $stripped_list - } - value { - tcl::dict::set values_dict $argname $stripped_list - } - } - } else { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict [lindex $stripped_list 0] - } - option { - tcl::dict::set opts $argname [lindex $stripped_list 0] - } - value { - tcl::dict::set values_dict [lindex $stripped_list 0] - } - } - } - } - } - - #maintain order of opts $opts values $values as caller may use lassign. - set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] - if {[llength $receivednames]} { - #flat zip of names with overall posn, including opts - #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] - set i -1 - set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] - } else { - set received_posns [list] - } - #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) - #(e.g using 'dict exists $received -flag') - # - but it can have duplicate keys when args/opts have -multiple 1 - #It is actually a list of paired elements - return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns] - } - - #proc sample1 {p1 args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [opt {?option value...?}]] - # #[para]Description of sample1 - # return "ok" - #} - - - lappend PUNKARGS [list { - @id -id ::punk::args::TEST - @opts -optional 0 - -o1 -default 111 -help "opt 1 mandatory" - @opts -optional 1 - -o2 -default 222 -help "opt 2 optional" - @values -min 0 -max 1 - v -help\ - "v1 optional" - }] - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::lib { - variable PUNKARGS - tcl::namespace::export * - tcl::namespace::path [list [tcl::namespace::parent]] - #*** !doctools - #[subsection {Namespace punk::args::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 flatzip {l1 l2} { - concat {*}[lmap a $l1 b $l2 {list $a $b}] - } - - if {[info commands lseq] ne ""} { - #tcl 8.7+ lseq significantly faster, especially for larger ranges - #The internal rep can be an 'arithseries' with no string representation - proc zero_based_posns {count} { - if {$count < 1} {return} - lseq 0 $count-1 - } - } else { - proc zero_based_posns {count} { - if {$count < 1} {return} - lsearch -all [lrepeat $count 0] * - } - } - - - #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 -1] in calling scope ${[lindex [set x] 0]} !} - lappend PUNKARGS [list { - @id -id ::punk::args::lib::tstr - @cmd -name punk::args::lib::tstr -help\ - "A rough equivalent of js template literals - - Substitutions: - \$\{$varName\} - \$\{[myCommand]\} - (when -allowcommands flag is given)" - -allowcommands -default 0 -type none -help\ - "If -allowcommands is present, placeholder can contain commands - e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" - -undent -default 1 -type boolean -help\ - "undent/dedent the template lines. - The longest common prefix of whitespace is removed" - -indent -default "" -type string -help\ - "String with which to indent the template - prior to substitution. - If -undent is enabled, that is performed - first, then the indent is applied." - -paramindents -default line -choices {none line position} -choicelabels { - line\ - " Use leading whitespace in - the line in which the - placeholder occurs." - position\ - " Use the position in - the line in which the - placeholder occurs." - none\ - " No indents applied to - subsequent placeholder value - lines. This will usually - result in text awkwardly - ragged unless the source code - has also been aligned with the - left margin or the value has - been manually padded." - } -help\ - "How indenting is done for subsequent lines in a - multi-line placeholder substitution value. - The 1st line or a single line value is always - placed at the placeholder. - paramindents are performed after the main - template has been indented/undented. - (indenting by position does not calculate - unicode double-wide or grapheme cluster widths) - " - #choicelabels indented by 1 char is clearer for -return string - and reasonable in table - -return -default string -choices {dict list string args}\ - -choicelabels { - dict\ - " Return a dict with keys - 'template', 'params' and - 'errors'" - string\ - " Return a single result - being the string with - placeholders substituted." - list\ - " Return a 2 element list. - The first is itself a list - of plaintext portions of the - template, split at each point - at which placeholders were - present. The second element - of the outer list is a list - of placeholder values if -eval - is 1, or a list of the raw - placeholder strings if -eval - is 0." - args\ - " Return a list where the first - element is a list of template - plaintext sections as per the - 'list' return mechanism, but the - placeholder items are individual - items in the returned list. - This can be useful when passing - the expanded result of a tstr - command to another function - which expects the placeholders - as individual arguments" - } - -eval -default 1 -type boolean -help\ - "Whether to evaluate the \$\{\} placeholders. - When -return is string, -eval should generally be set to 1. - For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. - contained variables in that case should be braced or whitespace separated, or the variable - name is likely to collide with surrounding text. - e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" - @values -min 0 -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 - e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} - - Escape sequences such as \\n and unicode escapes are processed within placeholders. - " - }] - - proc tstr {args} { - #Too hard to fully eat-our-own-dogfood from within punk::args package - # - we use punk::args within the unhappy path only - #set argd [punk::args::get_by_id ::punk::lib::tstr $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 opt_eval [dict get $argd opts -eval] - - set templatestring [lindex $args end] - set arglist [lrange $args 0 end-1] - set opts [dict create\ - -allowcommands 0\ - -undent 1\ - -indent ""\ - -paramindents line\ - -eval 1\ - -return string\ - ] - if {"-allowcommands" in $arglist} { - set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] - dict set opts -allowcommands 1 - } - if {[llength $arglist] % 2 != 0} { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr expected option/value pairs prior to last argument" - } - } - dict for {k v} $arglist { - set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] - switch -- $fullk { - -indent - -undent - -paramindents - -return - -eval { - dict set opts $fullk $v - } - default { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" - } - } - } - } - set opt_allowcommands [dict get $opts -allowcommands] - set opt_paramindents [dict get $opts -paramindents] - set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] - if {$test_paramindents ni {none line position}} { - error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." - } - set opt_paramindents $test_paramindents - set opt_return [dict get $opts -return] - set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] - if {$opt_return eq ""} { - } - set opt_eval [dict get $opts -eval] - - - set nocommands "-nocommands" - if {$opt_allowcommands == 1} { - set nocommands "" - } - - set opt_undent [dict get $opts -undent] - if {$opt_undent} { - set templatestring [punk::args::lib::undent $templatestring] - } - set opt_indent [dict get $opts -indent] - if {$opt_indent ne ""} { - set templatestring [punk::args::lib::indent $templatestring $opt_indent] - } - - #set parts [_tstr_split $templatestring] - if {[string first \$\{ $templatestring] < 0} { - set parts [list $templatestring] - } else { - set parts [_parse_tstr_parts $templatestring] - } - set textchunks [list] - #set expressions [list] - set params [list] - set idx 0 - set errors [dict create] - set lastline "" ;#todo - first line has placeholder? - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach {pt expression} $parts { - lappend textchunks $pt - incr idx ;#pt incr - - #ignore last expression - if {$idx == [llength $parts]} { - break - } - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - #lappend expressions $expression - #---------------------- - #REVIEW - JMN - #TODO - debug punk::args loading of @dynamic defs - #puts "-- $expression" - #---------------------- - #brk1 - literal newline not {\n} - set leader "" - if {[set brk1 [string first \n $expression]] >= 0} { - #undent left of paramstart only for lines of expression that arent on opening ${..} line - set tail [string range $expression $brk1+1 end] - set leader [string repeat " " [string length $lastline]] - set undentedtail [punk::args::lib::undentleader $tail $leader] - #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] - set expression "[string range $expression 0 $brk1]$undentedtail" - } - if {$opt_eval} { - if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { - lappend params [string cat \$\{ $expression \}] - dict set errors [expr {[llength $params]-1}] $result - } else { - set result [string map [list \n "\n$leader"] $result] - lappend params $result - } - #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] - } else { - lappend params [subst -nocommands -novariables $expression] - } - append lastline [lindex $params end] ;#for current expression's position calc - - incr idx ;#expression incr - } - - if {$opt_return eq "dict"} { - return [dict create template $textchunks params $params errors $errors] - } - if {[dict size $errors]} { - set einfo "" - dict for {i e} $errors { - append einfo "parameter $i error: $e" \n - } - #REVIEW!!! - #TODO - fix - #puts stderr "tstr errors:\n$einfo\n" - } - - switch -- $opt_return { - list { - return [list $textchunks $params] - } - args { - #see example in tstr_test_one - return [list $textchunks {*}$params] - } - string { - #todo - flag to disable indent-matching behaviour for multiline param? - set out "" - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach pt $textchunks param $params { - if {$opt_paramindents eq "none"} { - append out $pt $param - } else { - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - if {$opt_paramindents eq "line"} { - regexp {(\s*).*} $lastline _all lastindent - } else { - #position - #TODO - detect if there are grapheme clusters - #This regsub doesn't properly space unicode double-wide chars or clusters - set lastindent "[regsub -all {\S} $lastline " "] " - } - if {$lastindent ne ""} { - set paramlines [split $param \n] - if {[llength $paramlines] == 1} { - append out $pt $param - } else { - append out $pt [lindex $paramlines 0] - foreach nextline [lrange $paramlines 1 end] { - append out \n $lastindent $nextline - } - } - } else { - append out $pt $param - } - append lastline $param - } - } - return $out - } - } - } - #test single placeholder tstr args where single placeholder must be an int - proc tstr_test_one {args} { - set argd [punk::args::get_dict { - @cmd -name ::punk::args::lib::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 -return args {Select * from table where id = \$\{$id\} and etc... ;}] - } - - @values -min 2 -max 2 - template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - - but the tstr call in the example 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]] ""] - set result [string cat [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 dollar sign - 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]] - } - - #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. - proc indent {text {prefix " "}} { - set result [list] - foreach line [split $text \n] { - if {[string trim $line] eq ""} { - lappend result "" - } else { - lappend result $prefix[string trimright $line] - } - } - return [join $result \n] - } - #dedent? - proc undent {text} { - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - regexp {^([\t ]*)} $lcp _m lcp - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - - #hacky - proc undentleader {text leader} { - #leader usually whitespace - but doesn't have to be - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - lappend nonblank "${leader}!!" - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - #regexp {^([\t ]*)} $lcp _m lcp - #lcp can be shorter than leader - set lcp [string range $lcp 0 [string length $leader]-1] - - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - #A version of textutil::string::longestCommonPrefixList - proc longestCommonPrefix {items} { - if {[llength $items] <= 1} { - return [lindex $items 0] - } - set items [lsort $items[unset items]] - set min [lindex $items 0] - set max [lindex $items end] - #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) - #(sort order nothing to do with length - e.g min may be longer than max) - if {[string length $min] > [string length $max]} { - set temp $min - set min $max - set max $temp - } - set n [string length $min] - set prefix "" - set i -1 - while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { - append prefix $c - } - return $prefix - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] -} - -tcl::namespace::eval punk::args::argdocbase { - namespace export * - #use a? to test and create literal ansi here rather than relying on punk::ansi package presence - #e.g - #% a? bold - #- bold │SGR 1│sample│␛[1msample - #- ──────┼─────┼──────┼────────── - #- RESULT│ │sample│␛[1msample - proc B {} {return \x1b\[1m} ;#a+ bold - proc N {} {return \x1b\[22m} ;#a+ normal - proc I {} {return \x1b\[3m} ;#a+ italic - proc NI {} {return \x1b\[23m} ;#a+ noitalic - -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::package { - variable PUNKARGS - lappend PUNKARGS [list { - @dynamic - @id -id "::punk::args::package::standard_about" - @cmd -name "%pkg%::about" -help\ - "About %pkg% - ... - " - -package_about_namespace -type string -optional 0 -help\ - "Namespace containing the package about procedures - Must contain " - -return\ - -type string\ - -default table\ - -choices {string table tableobject}\ - -choicelabels { - string\ - "A basic text layout" - table\ - "layout in table borders - (requires package: textblock)" - tableobject\ - "textblock::class::table object instance" - }\ - -help\ - "Choose the return type of the 'about' information" - topic -optional 1\ - -nocase 1\ - -default {*}\ - -choices {Description License Version Contact *}\ - -choicerestricted 0\ - -choicelabels { - - }\ - -multiple 1\ - -help\ - "Topic to display. Omit or specify as * to see all. - If * is included with explicit topics, * represents - the remaining unmentioned topics." - }] - proc standard_about {args} { - set argd [punk::args::parse $args withid ::punk::args::package::standard_about] - lassign [dict values $argd] leaders OPTS values received - - set pkgns [dict get $OPTS -package_about_namespace] - if {[info commands ${pkgns}::package_name] eq ""} { - error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" - } - set pkgname [${pkgns}::package_name] - - set opt_return [dict get $OPTS -return] - set all_topics [${pkgns}::about_topics] - if {![dict exists $received topic]} { - set topics $all_topics - } else { - # * represents all remaining topics not explicitly mentioned. - set val_topics [dict get $values topic] ;#if -multiple is true, this is a list - set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] - set topics [list] - foreach t $val_topics { - if {$t eq "*"} { - foreach a $all_topics { - if {$a ni $explicit_topics} { - lappend topics $a - } - } - } else { - lappend topics $t - } - } - } - if {$opt_return ne "string"} { - package require textblock ;#table support - set is_table 1 - set title [string cat {[} $pkgname {]} ] - set t [textblock::class::table new -title $title] - $t configure -frametype double -minwidth [expr {[string length $title]+2}] - - } else { - set topiclens [lmap t $topics {string length $t}] - set widest_topic [tcl::mathfunc::max {*}$topiclens] - set is_table 0 - set about "$pkgname\n" - append about [string repeat - $widest_topic] \n - } - foreach topic $topics { - if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { - set topic_contents [::${pkgns}::get_topic_$topic] - } else { - set topic_contents "" - } - if {!$is_table} { - set content_lines [split $topic_contents \n] - append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n - foreach ln [lrange $content_lines 1 end] { - append about [format %-${widest_topic}s ""] " " $ln \n - } - } else { - $t add_row [list $topic $topic_contents] - } - } - - if {!$is_table} { - return $about - } else { - if {$opt_return eq "tableobject"} { - return $t - } - set result [$t print] - $t destroy - return $result - } - } - -} - -#usually we would directly call arg definitions near the defining proc, -# so that the proc could directly use the definition in its parsing. -# -#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. -#arguably it may be more processor-cache-efficient to do together like this anyway. - -#can't do this here? - as there is circular dependency with punk::lib -#tcl::namespace::eval punk::args { -# foreach deflist $PUNKARGS { -# punk::args::define {*}$deflist -# } -# set PUNKARGS "" -#} - -lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -tcl::namespace::eval punk::args::system { - #*** !doctools - #[subsection {Namespace punk::args::system}] - #[para] Internal functions that are not part of the API - - #dict get value with default wrapper for tcl 8.6 - if {[info commands ::tcl::dict::getdef] eq ""} { - proc Dict_getdef {dictValue args} { - set keys [lrange $args 0 end-1] - if {[tcl::dict::exists $dictValue {*}$keys]} { - return [tcl::dict::get $dictValue {*}$keys] - } else { - return [lindex $args end] - } - } - } else { - #we pay a minor perf penalty for the wrap - interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef - } - - #name to reflect maintenance - home is punk::lib::ldiff - proc punklib_ldiff {fromlist removeitems} { - if {[llength $removeitems] == 0} {return $fromlist} - set result {} - foreach item $fromlist { - if {$item ni $removeitems} { - lappend result $item - } - } - return $result - } - -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::args [tcl::namespace::eval punk::args { - tcl::namespace::path {::punk::args::lib ::punk::args::system} - variable pkg punk::args - variable version - set version 0.1.0 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.1.tm deleted file mode 100644 index 2d8de97d..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.1.tm +++ /dev/null @@ -1,5341 +0,0 @@ -# -*- 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: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.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 punk::args 0.1.0 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.1.0] -#[copyright "2024"] -#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] -#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] -#[require punk::args] -#[keywords module proc args arguments parse] -#[description] -#[para]Utilities for parsing proc args - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). -#[para] overview of punk::args -#[subsection Concepts] -#[para]There are 2 main conventions for parsing a proc args list -#[list_begin enumerated] -#[enum] -#[para]leading option-value pairs and flags followed by a list of values (Tcl style) -#[enum] -#[para]leading list of values followed by option-value pairs and flags (Tk style) -#[list_end] -#[para]There are exceptions in both Tcl and Tk commands regarding this ordering -#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style -#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] -#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. -#[para] -#[para]The basic principle is that a call to punk::args::get_dict is made near the beginning of the proc with a cacheable first argument defining the parameters e.g -#[example { -# proc dofilestuff {args} { -# lassign [dict values [punk::args::get_dict { -# @cmd -help "do some stuff with files e.g dofilestuff " -# @opts -type string -# #comment lines ok -# -directory -default "" -# -translation -default binary -# #setting -type none indicates a flag that doesn't take a value (solo flag) -# -nocomplain -type none -# @values -min 1 -max -1 -# } $args]] leaders opts values -# -# puts "translation is [dict get $opts -translation]" -# foreach f [dict values $values] { -# puts "doing stuff with file: $f" -# } -# } -#}] -#[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls -#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values -#[para]valid @ lines being with @cmd @leaders @opts @values -#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. -#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. -#[para]e.g the result from the punk::args call above may be something like: -#[para] opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} -#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments -#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments -#[example { -# proc dofilestuff {category args} { -# lassign [dict values [punk::args::get_dict { -# -directory -default "" -# -translation -default binary -# -nocomplain -type none -# @values -min 2 -max 2 -# fileA -type existingfile 1 -# fileB -type existingfile 1 -# } $args]] leaders opts values -# puts "$category fileA: [dict get $values fileA]" -# puts "$category fileB: [dict get $values fileB]" -# } -#}] -#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 -#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored -#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, -#[para] or an additional call could be made to punk::args e.g -#[example { -# punk::args::get_dict { -# category -choices {cat1 cat2 cat3} -# another_leading_arg -type boolean -# } [list $category $another_leading_arg] -#}] - -#*** !doctools -#[subsection Notes] -#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. -#[para] -#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. -#For functions that are part of an API a package may be more suitable. -#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) -#[example { -# proc test_switch {args} { -# set opts [dict create\\ -# -return "object"\\ -# -frametype "heavy"\\ -# -show_edge 1\\ -# -show_seps 0\\ -# -x a\\ -# -y b\\ -# -z c\\ -# -1 1\\ -# -2 2\\ -# -3 3\\ -# ] -# foreach {k v} $args { -# switch -- $k { -# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { -# dict set opts $k $v -# } -# default { -# error "unrecognised option '$k'. Known options [dict keys $opts]" -# } -# } -# } -# return $opts -# } -#}] -#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. -#[para] -# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. -# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. -#[para]use punk::lib::show_jump_tables to verify that a jump table exists. -#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous -#[example { -# proc test_prefix {args} { -# set opts [dict create\ -# -return string\ -# -frametype \uFFEF\ -# -show_edge \uFFEF\ -# -show_seps \uFFEF\ -# -x a\ -# -y b\ -# -z c\ -# -1 1\ -# -2 2\ -# -3 3\ -# ] -# if {[llength $args]} { -# set knownflags [dict keys $opts] -# } -# foreach {k v} $args { -# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v -# } -# return $opts -# } -#}] -#[para]There are many alternative args parsing packages a few of which are listed here. -#[list_begin enumerated] -#[enum]argp (pure tcl) -#[enum]parse_args (c implementation) -#[enum]argparse (pure tcl *) -#[enum]cmdline (pure tcl) -#[enum]opt (pure tcl) distributed with Tcl but considered deprecated -#[enum]The tcllib set of TEPAM modules (pure tcl) -#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. -#[list_end] -#[para] (* c implementation planned/proposed) -#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. -#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences -#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. -#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. -#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. -#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. -#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -#All ensemble commands are slower in a safe interp as they aren't compiled the same way -#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 -#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. -#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) -#ensembles: array binary clock dict info namespace string -#possibly file too, although that is generally hidden/modified in a safe interp -#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc -#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::args -#[list_begin itemized] -package require Tcl 8.6- -#optional? punk::trie -#optional? punk::textblock -#*** !doctools -#[item] [package {Tcl 8.6-}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -tcl::namespace::eval punk::args::register { - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] cooperative namespace punk::args::register - #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded - #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. - #[list_begin definitions] - - #Although the actual punk::args::define calls are not too sluggish, there could be *many*. - #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, - #especially since a fair proportion may be for documentation purposes rather than parsing args. - - # -- --- --- --- --- --- --- --- - #cooperative with packages that define some punk args but do so lazily - #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first - variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective - if {![info exists ::punk::args::register::NAMESPACES]} { - set ::punk::args::register::NAMESPACES [list] - } - # -- --- --- --- --- --- --- --- - - variable loaded_packages [list] ;#fully loaded - variable loaded_info [dict create] ;#time - variable scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages - variable scanned_info [dict create] ;#time and idcount - #some packages, e.g punk::args::tclcore document other namespaces. - #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources - variable namespace_docpackages [dict create] - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::register ---}] -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args { - - - variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. - - tcl::namespace::export {[a-z]*} - variable rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} - variable id_cache_rawdef [tcl::dict::create] - variable id_cache_spec [tcl::dict::create] - - variable argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) - - variable argdata_cache [tcl::dict::create] - - variable id_counter 0 - - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] Core API functions for punk::args - #[list_begin definitions] - - #todo - some sort of punk::args::cherrypick operation to get spec from an existing set - #todo - doctools output from definition - - - - - #todo? -synonym/alias ? (applies to opts only not values) - #e.g -background -aliases {-bg} -default White - #review - how to make work with trie prefix - #e.g - # -corner -aliases {-corners} - # -centre -aliases {-center -middle} - #We mightn't want the prefix to be longer just because of an alias - #we should get -co -ce and -m from the above as abbreviations - - set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] - - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::define - #todo @preamble -help "move large block outside of table?" - @cmd -name punk::args::define -help\ - "Accepts a line-based definition of command arguments. - Returns a dictionary representing the argument specifications. - - The return result can generally be ignored, as the record is stored keyed on the - @id -id value from the supplied definition. - This specifications dictionary is structured for (optional) use within commands to - parse and validate the arguments - and is also used when retrieving definitions - (or parts thereof) for re-use. - - This can be used purely for documentation or called within a function to parse a mix - of leading values, switches/flags and trailing values. - - The overhead is favourably comparable with other argument processors - but none are - as fast as minimal code with a switch statement. For toplevel commands where a few - 10s of microseconds is immaterial, the validation and automated error formatting in - a table can be well worthwhile. For inner procs requiring utmost speed, the call can - be made only on the unhappy path when basic processing determines a mismatch - or it - can be left entirely as documentation for interactive use with: i ... - - The definition should usually contain an initial line of the form: @id -id ::somecmd - - Blank lines are ignored at the top level, ie if they are not part of another structure. - Similarly - lines at the top level begginning with the # character are ignored. - All other toplevel lines must consist of a leading word followed by paired arguments. - The arguments can be spread over multiple lines and contain lines of near-arbitrary - text if they are properly braced or double quoted and Tcl escaping for inner quotes - or unbalanced braces is maintained. - The line continuation character - (\\ at the end of the line) can be used to continue the set of arguments for - a leading word. - Leading words beginning with the @ character are directives controlling argument - parsing and help display. - directives include: - %B%@id%N% ?opt val...? - spec-options: -id - %B%@cmd%N% ?opt val...? - spec-options: -name -help - %B%@leaders%N% ?opt val...? - spec-options: -min -max - (used for leading args that come before switches/opts) - %B%@opts%N% ?opt val...? - spec-options: -any - %B%@values%N% ?opt val...? - spec-options: -min -max - (used for trailing args that come after switches/opts) - %B%@argdisplay%N% ?opt val...? - spec-options: -header (text for header row of table) - -body (text to replace autogenerated arg info) - %B%@doc%N% ?opt val...? - spec-options: -name -url - %B%@seealso%N% ?opt val...? - spec-options: -name -url (for footer - unimplemented) - - Some other spec-options normally present on custom arguments are available - to use with the @leaders @opts @values directives to set defaults - for subsequent lines that represent your custom arguments. - These directives should occur in exactly this order - but can be - repeated with custom argument lines interspersed. - - An @id line can only appear once and should be the first item. - For the commandline usage to be displayed either on parsing error - or using the i .. function - an @id with -id is needed. - - All directives can be omitted, in which case every line represents - a custom leader, value or option. - All will be leaders by default if no options defined. - If options are defined (by naming with leading dash, or explicitly - specifying @opts) then the definitions prior to the options will be - categorised as leaders, and those following the options will be - categorised as values. - - Custom arguments are defined by using any word at the start of a - line that doesn't begin with @ or - - (except that adding an additionl @ escapes this restriction so - that @@somearg becomes an argument named @somearg) - - custom leading args, switches/options (names starting with -) - and trailing values also take spec-options: - - -type - defaults to string. If no other restrictions - are specified, choosing string does the least validation. - recognised types: - none - (used for switches only. Indicates this is - a 'solo' flag ie accepts no value) - int|integer - list - dict - double - bool|boolean - char - file - directory - string - ansistring - globstring - (any of the types accepted by 'string is') - - These all perform some validation checks - - and more.. (todo - document here) - - -optional - (defaults to true for flags/switches false otherwise) - For non flag/switch arguments - all arguments with - -optional true must sit consecutively within their group. - ie all optional leader arguments must be together, and all - optional value arguments must be together. Furthermore, - specifying both optional leaders and optional values will - often lead to ambiguous parsing results. Currently, all - optional non-flg/switch arguments should be either at the - trailing end of leaders or the trailing end of values. - Further unambiguous arrangements of optional args may be - made in future - but are currently considered 'unsupported' - -default - -multiple (for leaders & values defines whether - subsequent received values are stored against the same - argument name - only applies to final leader OR final value) - (for options/flags this allows the opt-val pair or solo - flag to appear multiple times - not necessarily contiguously) - -choices {} - A list of allowable values for an argument. - The -default value doesn't have to be in the list. - If a -type is specified - it doesn't apply to choice members. - It will only be used for validation if the -choicerestricted - option is set to false. - -choicerestricted - Whether values not specified in -choices or -choicegroups are - allowed. Defaults to true. - -choiceprefix - This specifies whether unique prefixes are able to be used - instead of the complete string. This is calculated using - tcl::prefix::match - and will display in the autogenerated - usage output. Defaults to true. - -choiceprefixdenylist {} - These choices should match exactly a choice entry in one of - the settings -choices or -choicegroups. - These will still be used in prefix calculation - but the full - choice argument must be entered to select the choice. - -choicegroups {} - Generally this would be used instead of -choices to allow - usage display of choices grouped by some name. - See for example the output if 'i zlib' where choices of the - next subcommand are grouped by the names compression,channel, - streaming and checksumming. The -choices list is equivalent - to a -choicegroups dict entry where the key (groupname) is - the empty string. - -choicemultiple (default {1 1}) - is a pair representing min and max number of choices - that can be present in the value. - If is a single integer it is equivalent to a - specified with the same integer for both min and max. - Max of -1 represents no upper limit. - If allows more than one choice the value is a list - consisting of items in the choices made available through - entries in -choices/-choicegroups. - -minsize (type dependant) - -maxsize (type dependant) - -range (type dependant) - - - " - -dynamic -type boolean -default 0 -help\ - "If -dynamic is true, tstr interpolations of the form \$\{\$var\} - are re-evaluated on each call. - If the definition is being used not just as documentation, but is also - used within the function to parse args, e.g using punk::args::get_by_id, - then it should be noted that there is a slight performance penalty for the - dynamic case. - It is often not significant, perhaps depending on what vars/commands are - used but -dynamic true might be less desirable if the command is used in - inner loops in more performance-sensitive code. - " - @values -min 1 -max -1 - text -type string -multiple 1 -help\ - "Block(s) of text representing the argument definition for a command. - At least one must be supplied. If multiple, they are joined together with \\n. - Using multiple text arguments may be useful to mix curly-braced and double-quoted - strings to have finer control over interpolation when defining arguments. - (this can also be handy for sections that pull resolved definition lines - from existing definitions (by id) for re-use of argument specifications and help text) - - e.g the following definition passes 2 blocks as text arguments - definition { - @id -id ::myns::myfunc - @cmd -name myns::myfunc -help\\ - \"Description of command\" - - #The following option defines an option-value pair - -option1 -default blah -type string - #The following option defines a flag style option (solo) - -flag1 -default 0 -type none -help\\ - \"Info about flag1 - subsequent help lines auto-dedented by whitespace to left - of corresponding record start (in this case -flag1) - + first 4 spaces if they are all present. - This line has no extra indent relative to first line 'Info about flag1' - This line indented a further 6 chars\" - - @values -min 1 -max -1 - #Items that don't begin with * or - are value definitions - v1 -type integer -default 0 - thinglist -type string -multiple 1 - } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" - " - }]] - - proc New_command_form {name} { - #probably faster to inline a literal dict create in the proc than to use a namespace variable - set leaderspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - set optspec_defaults [tcl::dict::create\ - -type string\ - -optional 1\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - set valspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - - #form record can have running entries such as 'argspace' that aren't given to arg parser - #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict - return [dict create\ - argspace "leaders"\ - ARG_INFO [tcl::dict::create]\ - ARG_CHECKS [tcl::dict::create]\ - LEADER_DEFAULTS [tcl::dict::create]\ - LEADER_REQUIRED {}\ - LEADER_NAMES {}\ - LEADER_MIN ""\ - LEADER_MAX ""\ - leaderspec_defaults $leaderspec_defaults\ - LEADER_CHECKS_DEFAULTS {}\ - opt_default {}\ - opt_required {}\ - OPT_NAMES {}\ - opt_any {}\ - opt_solos {}\ - optspec_defaults $optspec_defaults\ - OPT_CHECKS_DEFAULTS {}\ - val_defaults {}\ - val_required {}\ - VAL_NAMES {}\ - val_min ""\ - val_max ""\ - valspec_defaults $valspec_defaults\ - VAL_CHECKS_DEFAULTS {}\ - argdisplay_info ""\ - ] - - #set argdata_dict [tcl::dict::create\ - # id $DEF_definition_id\ - # arg_info $arg_info\ - # arg_checks $arg_checks\ - # leader_defaults $leader_defaults\ - # leader_required $leader_required\ - # leader_names $leader_names\ - # leader_min $leader_min\ - # leader_max $leader_max\ - # leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ - # leader_checks_defaults $leader_checks_defaults\ - # opt_defaults $opt_defaults\ - # opt_required $opt_required\ - # opt_names $opt_names\ - # opt_any $opt_any\ - # opt_solos $opt_solos\ - # optspec_defaults [dict get $F $firstformid optspec_defaults]\ - # opt_checks_defaults $opt_checks_defaults\ - # val_defaults $val_defaults\ - # val_required $val_required\ - # val_names $val_names\ - # val_min $val_min\ - # val_max $val_max\ - # valspec_defaults [dict get $F $firstformid valspec_defaults]\ - # val_checks_defaults $val_checks_defaults\ - # cmd_info $cmd_info\ - # doc_info $doc_info\ - # argdisplay_info $argdisplay_info\ - # id_info $id_info\ - # form_defs $F\ - #] - } - proc define {args} { - dict get [resolve {*}$args] id - } - proc resolve {args} { - variable rawdef_cache - variable id_cache_rawdef - if {[dict exists $rawdef_cache $args]} { - set id [dict get $rawdef_cache $args -id] - set is_dynamic [dict get $rawdef_cache $args -dynamic] - } else { - set id [rawdef_id $args] - set is_dynamic [rawdef_is_dynamic $args] - dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] - dict set id_cache_rawdef $id $args - } - - - variable argdata_cache - variable argdefcache_unresolved - - - set cache_key $args - #ideally we would use a fast hash algorithm to produce a short key with low collision probability. - #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) - #review - check if there is a built-into-tcl way to do this quickly - #for now we will just key using the whole string - #performance seems ok - memory usage probably not ideal - #quote from DKF 2021 - #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. - #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. - #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. - #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). - #> If dealing with very large amounts of data, using a database is probably a good plan. - - set textargs $args - if {![llength $args]} { - punk::args::get_by_id ::punk::args::define {} - return - } - if {[lindex $args 0] eq "-dynamic"} { - set is_dynamic [lindex $args 1] - set textargs [lrange $args 2 end] - } - - if {!$is_dynamic} { - if {[tcl::dict::exists $argdata_cache $cache_key]} { - return [tcl::dict::get $argdata_cache $cache_key] - } - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - if {[string first \$\{ $optionspecs] > 0} { - set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } - } else { - #we are always doing our first subst during the define.. shouldn't it be a separate resolve somehow? optionally so at least? - - if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { - set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel 1 [list ::subst $param]] - } - } else { - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) - if {[string first \$\{ $optionspecs] > 0} { - set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel 1 [list ::subst $param]] - } - tcl::dict::set argdefcache_unresolved $cache_key $pt_params - } - } - #argdata_cache should be limited in some fashion or will be a big memory leak??? - if {[tcl::dict::exists $argdata_cache $optionspecs]} { - #resolved cache version exists - return [tcl::dict::get $argdata_cache $optionspecs] - } - } - - - - #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices - #default to 1 for convenience - - #checks with no default - #-minsize -maxsize -range - - - #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi - #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist - set opt_required [list] - set val_required [list] - - set opt_defaults [tcl::dict::create] - - set val_defaults [tcl::dict::create] - set opt_solos [list] - #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end - - set records [list] - set linebuild "" - - set linelist [split $optionspecs \n] - set lastindent "" - foreach ln $linelist { - if {[tcl::string::trim $ln] eq ""} {continue} - regexp {(\s*).*} $ln _all lastindent - break ;#break at first non-empty - } - #puts "indent1:[ansistring VIEW $lastindent]" - set in_record 0 - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - foreach rawline $linelist { - set recordsofar [tcl::string::cat $linebuild $rawline] - #ansi colours can stop info complete from working (contain square brackets) - #review - when exactly are ansi codes allowed/expected in record lines. - # - we might reasonably expect them in default values or choices or help strings - # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. - # - eg set line "set x \"a[a+ red]red[a]\"" - # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket - if {$has_punkansi} { - set test_complete [punk::ansi::ansistrip $recordsofar] - } else { - #review - #we only need to strip enough to stop interference with 'info complete' - set test_complete [string map [list \x1b\[ ""] $recordsofar] - } - if {![tcl::info::complete $test_complete]} { - #append linebuild [string trimleft $rawline] \n - if {$in_record} { - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. - #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. - #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. - #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) - #(note string first "" $str is fast and returns -1) - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline \n - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline \n - } else { - append linebuild $rawline \n - } - } else { - set in_record 1 - regexp {(\s*).*} $rawline _all lastindent - #puts "indent: [ansistring VIEW -lf 1 $lastindent]" - #puts "indent from rawline:$rawline " - append linebuild $rawline \n - } - } else { - set in_record 0 - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline - } else { - append linebuild $rawline - } - lappend records $linebuild - set linebuild "" - } - } - set cmd_info {} - set package_info {} - set id_info {} ;#e.g -children ?? - set doc_info {} - set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table - set seealso_info {} - set keywords_info {} - ###set leader_min 0 - ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit - #set leader_max "" - #(common case of no leaders specified) - set opt_any 0 - set val_min 0 - set val_max -1 ;#-1 for no limit - set DEF_definition_id $id - - #form_defs - set F [dict create _default [New_command_form _default]] - set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under - - #set ARGSPACE [dict create] ;#keyed on form - #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values - - set refs [dict create] - set record_type "" - set record_number -1 ;# - foreach rec $records { - set trimrec [tcl::string::trim $rec] - switch -- [tcl::string::index $trimrec 0] { - "" - # {continue} - } - incr record_number - set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict - if {[llength $record_values] % 2 != 0} { - #todo - avoid raising an error - store invalid defs keyed on id - error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" - } - # ---------------------------------------------------------- - # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. - #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! - #(form_ids_active is otherwise set in the @form handling block) - - #consider the following 2 line entry which is potentially dynamically included via a tstr: - # @form -form {* newform} - # @form -form {newform} -synopsis "cmd help ?stuff?" - #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. - #(because _default is usually 'taken over' by the first encountered form id) - #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record - #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. - - if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { - set patterns [dict get $record_values -form] - set record_form_ids [list] - foreach p $patterns { - if {[regexp {[*?\[\]]} $p]} { - #isglob - only used for matching existing forms - lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] - } else { - #don't test for existence - will define new form if necessary - lappend record_form_ids $p - } - } - #-form values could be globs that didn't match. record_form_ids could be empty.. - if {[llength $record_form_ids]} { - #only rename _default if it's the sole entry - if {[dict size $F] == 1 && [dict exists $F "_default"]} { - if {"_default" ni $record_form_ids} { - #only initial form exists - but we are mentioning new ones - #first rename the _default to first encountered new form id - #(just replace whole dict with new key - same data) - set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] - #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F - #we are only setting active because of the rename - @form is the way to change active forms list - set form_ids_active [lindex $record_form_ids 0] - } - } - foreach fid $record_form_ids { - if {![dict exists $F $fid]} { - if {$firstword eq "@form"} { - #only @form directly supplies keys - dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] - } else { - dict set F $fid [New_command_form $fid] - } - } else { - #update form with current record opts, except -form - if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } - } - } - } - } else { - #missing or empty -form - set record_form_ids $form_ids_active - if {$firstword eq "@form"} { - foreach fid $form_ids_active { - dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] - } - } - } - # ---------------------------------------------------------- - - set firstchar [tcl::string::index $firstword 0] - set secondchar [tcl::string::index $firstword 1] - if {$firstchar eq "@" && $secondchar ne "@"} { - set record_type "directive" - set directive_name $firstword - set at_specs $record_values - - switch -- [tcl::string::range $directive_name 1 end] { - dynamic { - set is_dynamic 1 - } - id { - #disallow duplicate @id line ? - #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) - - #id An id will be allocated if no id line present or the -id value is "auto" - - if {[dict exists $at_specs -id]} { - set thisid [dict get $at_specs -id] - if {$thisid ni [list $id auto]} { - error "punk::args::define @id mismatch existing: $id vs $thisid" - } - } - set id_info $at_specs - } - ref { - #a reference within the definition - #e.g see punk::args::tclcore ::after - #global reference dict - independent of forms - #ignore refs without an -id - #store all keys except -id - #complete overwrite if refid repeated later on - if {[dict exists $at_specs -id]} { - dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] - } - } - default { - #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple - #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) - #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) - #That is possibly too complicated and/or unnecessary? - #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? - - if {[dict exists $at_specs -id]} { - set copyfrom [get_spec [dict get $at_specs -id]] - #we don't copy the @id info from the source - #for now we only copy across if nothing set.. - #todo - bring across defaults for empty keys at targets? - #need to keep it simple enough to reason about behaviour easily.. - if {[dict size $copyfrom]} { - if {![dict size $cmd_info]} { - set cmd_info [dict get $copyfrom cmd_info] - } - if {![dict size $doc_info]} { - set doc_info [dict get $copyfrom doc_info] - } - foreach fid $record_form_ids { - #only use elements with matching form id? - #probably this feature mainly useful for _default anyway so that should be ok - #cooperative doc sets specified in same file could share via known form ids too - #todo argdisplay_info by fid - if {![dict size $argdisplay_info]} { - set argdisplay_info [dict get $copyfrom argdisplay_info] - } - #TODO - #create leaders opts vals depending on position of @default line? - #options on @default line to exclude/include sets??? - } - } - } - } - form { - # arity system ? - #handle multiple parsing styles based on arities and keyword positions (and/or flags?) - #e.g see lseq manual with 3 different parsing styles. - #aim to produce a table/subtable for each - # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ - # -arities { - # 2 - # {3 anykeys {1 .. 1 to}} - # {4 anykeys {3 by}} - # {5 anykeys {1 .. 1 to 3 by}} - # }\ - # -fallback 1 - # ... - # @parser -synopsis "start 'count' count ??'by'? step?"\ - # -arities { - # {3 anykeys {1 count}} - # } - # ... - # @form -synopsis "count ?'by' step?"\ - # -arities { - # 1 - # {3 anykeys {1 by}} - # } - # - # see also after manual - # @form -arities {1} - # @form -arities { - # 1 anykeys {0 info} - # } - #todo - - #can we generate a form synopsis if -synopsis not supplied? - - #form id can be list of ints|names?, or * - if {[dict exists $at_specs -form]} { - set idlist [dict get $at_specs -form] - if {$idlist eq "*"} { - #* only applies to form ids that exist at the time - set idlist [dict keys $F] - } - set form_ids_active $idlist - } - #new form keys already created if they were needed (done for all records that have -form ) - } - package { - set package_info [dict merge $package_info $at_specs] - } - cmd { - #allow arbitrary - review - set cmd_info [dict merge $cmd_info $at_specs] - } - doc { - set doc_info [dict merge $doc_info $at_specs] - } - argdisplay { - #override the displayed argument table. - #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing - set argdisplay_info [dict merge $argdisplay_info $at_specs] - } - opts { - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "values"} { - error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" - } - dict set F $fid argspace "options" - set tmp_optspec_defaults [dict get $F $fid optspec_defaults] - - foreach {k v} $at_specs { - switch -- $k { - -any - - -anyopts { - set opt_any $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { - #review - only apply to certain types? - tcl::dict::set tmp_optspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_optspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - none - "" - - - any - ansistring - globstring - list { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_optspec_defaults -type $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - #allow overriding of defaults for options that occur later - tcl::dict::set tmp_optspec_defaults $k $v - } - default { - set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" - } - } - } - dict set F $fid optspec_defaults $tmp_optspec_defaults - } ;# end foreach record_form_ids - } - leaders { - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] in [list options values]} { - error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" - } - set tmp_leaderspec_defaults [dict get $F $fid leaderspec_defaults] - - foreach {k v} $at_specs { - switch -- $k { - -min - - -minvalues { - if {$v < 0} { - error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MIN $v - #if {$leader_max == 0} { - # set leader_max -1 - #} - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MAX $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -choiceinfo { - if {[llength $v] %2 != 0} { - error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - #-choicegroups? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_leaderspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set tmp_leaderspec_defaults $k $v - } - default { - set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid leaderspec_defaults $tmp_leaderspec_defaults - - } ;#end foreach record_form_ids - - } - values { - foreach fid $record_form_ids { - dict set F $fid argspace "values" - - set tmp_valspec_defaults [dict get $F $fid valspec_defaults] - - foreach {k v} $at_specs { - switch -- $k { - -form { - } - -min - - -minvalues { - if {$v < 0} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" - } - set val_min $v - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" - } - set val_max $v - } - -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_valspec_defaults $k $v - } - -choiceinfo - -choicegroups { - if {[llength $v] % 2 != 0} { - error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - # -choicegroups ?? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_valspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set tmp_valspec_defaults $k $v - } - default { - set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid valspec_defaults $tmp_valspec_defaults - } - - } - seealso { - #todo! - #like @doc, except displays in footer, multiple - sub-table? - set seealso_info [dict merge $seealso_info $at_specs] - } - keywords { - #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? - set keywords_info [dict merge $keywords_info $at_specs] - } - default { - error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @argdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" - } - } - #record_type directive - continue - } elseif {$firstchar eq "-"} { - set argname $firstword - set argdef_values $record_values - tcl::dict::set argdef_values -ARGTYPE option - - - - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - dict set F $fid argspace "options" - } elseif {[dict get $F $fid argspace] eq "values"} { - error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" - } - set record_type option - dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] - #lappend opt_names $argname - } - - set is_opt 1 - } else { - set argname $firstword - if {$firstchar eq "@"} { - #allow basic @@ escaping for literal argname that begins with @ - set argname [tcl::string::range $argname 1 end] - } - - set argdef_values $record_values - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - set record_type leader - tcl::dict::set argdef_values -ARGTYPE leader - #lappend leader_names $argname - set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] - if {$argname ni $temp_leadernames} { - lappend temp_leadernames $argname - tcl::dict::set F $fid LEADER_NAMES $temp_leadernames - } else { - error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" - } - - if {[dict get $F $fid LEADER_MAX] >= 0} { - dict set F $fid LEADER_MAX [llength $temp_leadernames] - } - } else { - set record_type value - tcl::dict::set argdef_values -ARGTYPE value - set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] - lappend temp_valnames $argname - tcl::dict::set F $fid VAL_NAMES $temp_valnames - #lappend val_names $argname - } - } - - set is_opt 0 - } - - - #assert - we only get here if it is a value or flag specification line. - #assert argdef_values has been set to the value of record_values - - foreach fid $record_form_ids { - if {$is_opt} { - set spec_merged [dict get $F $fid optspec_defaults] - } else { - if {[dict get $F $fid argspace] eq "values"} { - set spec_merged [dict get $F $fid valspec_defaults] - } else { - set spec_merged [dict get $F $fid leaderspec_defaults] - } - } - - # -> argopt argval - foreach {spec specval} $argdef_values { - #literal-key switch - bytecompiled to jumpTable - switch -- $spec { - -form { - - } - -type { - #normalize here so we don't have to test during actual args parsing in main function - switch -- [tcl::string::tolower $specval] { - int - integer { - tcl::dict::set spec_merged -type int - } - bool - boolean { - tcl::dict::set spec_merged -type bool - } - char - character { - tcl::dict::set spec_merged -type char - } - dict - dictionary { - tcl::dict::set spec_merged -type dict - } - "" - none { - if {$is_opt} { - tcl::dict::set spec_merged -type none - 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 - error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" - } - } - any - anything { - tcl::dict::set spec_merged -type any - } - ansi - ansistring { - tcl::dict::set spec_merged -type ansistring - } - any - string - globstring { - tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - } - default { - #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW - tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - } - } - } - -default - -solo - -range - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo - - -minsize - -maxsize - -nocase - -optional - -multiple - - -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - - -regexprepass - -regexprefail - -regexprefailmsg - { - #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines - #review -solo 1 vs -type none ? conflicting values? - tcl::dict::set spec_merged $spec $specval - } - -validationtransform { - #string is dict only 8.7/9+ - if {[llength $specval] % 2} { - error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" - } - dict for {tk tv} $specval { - switch -- $tk { - -function - -type - -minsize - -maxsize - -range { - } - default { - set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? - error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" - } - } - } - - } - default { - if {[string match ref-* $spec]} { - #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) - #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. - if {![tcl::dict::exists $refs $specval]} { - puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" - } else { - set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" - if {$targetswitch eq "-*"} { - set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id - } else { - if {[tcl::dict::exists $refs $specval $targetswitch]} { - tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] - } else { - puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" - } - } - } - } else { - set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - ] - error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" - } - } - } - } ;# end foreach {spec specval} argdef_values - - - if {$is_opt} { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } else { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - tcl::dict::set F $fid ARG_INFO $argname $spec_merged - #review existence of -default overriding -optional - if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { - if {$is_opt} { - lappend opt_required $argname - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - set temp_leader_required [dict get $F $fid LEADER_REQUIRED] - lappend temp_leader_required $argname - dict set F $fid LEADER_REQUIRED $temp_leader_required - #lappend leader_required $argname - } else { - lappend val_required $argname - } - } - } - if {[tcl::dict::exists $spec_merged -default]} { - if {$is_opt} { - tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } else { - tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] - } - } - } - } ;# end foreach fid record_form_ids - - } ;# end foreach rec $records - - - #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { - # variable id_counter - # set DEF_definition_id "autoid_[incr id_counter]" - #} - - - #check ALL forms not just form_ids_active (record_form_ids) - dict for {fid formdata} $F { - # REVIEW - #no values specified - we can allow last leader to be multiple - foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { - error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" - } - } - #confirm any valnames before last don't have -multiple key - foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { - error "bad key -multiple on argument spec for value '$valname' in command form:'$fid'. Only the last value argument specification can be marked -multiple @id:$DEF_definition_id" - } - } - - #todo - document that ambiguities in API are likely if both @leaders and @values used - #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) - - - dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - - - - - #todo - precalculate a set of 'arity' entries for each form - #We want a structure for the arg parser to get easy access and make a fast decision on which form applies - #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? - #1) after ms (1 1) - #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? - #3) after cancel id (2 2) - #4) after cancel script ?script...? (2 -1) - #5) after idle script ?script...? (1 -1) - #6) after info ?id? (1 2) - - #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) - - #in the above case we have no unique total_arity - #we would also want to consider values when selecting - #e.g given the invalid command "after cancel" - # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. - - - - set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands - #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use - #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form - #e.g commandline completion could show list of synopsis entries to select from - - set form_info [dict create] - dict for {fid fdict} $F { - dict set form_info $fid {} - dict for {optk optv} $fdict { - if {[string match -* $optk]} { - dict set form_info $fid $optk $optv - } - } - } - - set argdata_dict [tcl::dict::create\ - id $DEF_definition_id\ - ARG_INFO [dict get $F $firstformid ARG_INFO]\ - ARG_CHECKS [dict get $F $firstformid ARG_CHECKS]\ - LEADER_DEFAULTS [dict get $F $firstformid LEADER_DEFAULTS]\ - LEADER_REQUIRED [dict get $F $firstformid LEADER_REQUIRED]\ - LEADER_NAMES [dict get $F $firstformid LEADER_NAMES]\ - LEADER_MIN [dict get $F $firstformid LEADER_MIN]\ - LEADER_MAX [dict get $F $firstformid LEADER_MAX]\ - leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ - LEADER_CHECKS_DEFAULTS [dict get $F $firstformid LEADER_CHECKS_DEFAULTS]\ - opt_defaults $opt_defaults\ - opt_required $opt_required\ - OPT_NAMES [dict get $F $firstformid OPT_NAMES]\ - opt_any $opt_any\ - opt_solos $opt_solos\ - optspec_defaults [dict get $F $firstformid optspec_defaults]\ - OPT_CHECKS_DEFAULTS [dict get $F $firstformid OPT_CHECKS_DEFAULTS]\ - val_defaults $val_defaults\ - val_required $val_required\ - VAL_NAMES [dict get $F $firstformid VAL_NAMES]\ - val_min $val_min\ - val_max $val_max\ - valspec_defaults [dict get $F $firstformid valspec_defaults]\ - VAL_CHECKS_DEFAULTS [dict get $F $firstformid VAL_CHECKS_DEFAULTS]\ - cmd_info $cmd_info\ - doc_info $doc_info\ - package_info $package_info\ - argdisplay_info $argdisplay_info\ - seealso_info $seealso_info\ - id_info $id_info\ - FORMS $F\ - form_names [dict keys $F]\ - FORM_INFO $form_info\ - ] - - tcl::dict::set argdata_cache $cache_key $argdata_dict - if {$is_dynamic} { - #also cache resolved version - tcl::dict::set argdata_cache $optionspecs $argdata_dict - } - - #tcl::dict::set id_cache_rawdef $DEF_definition_id $args - #puts "xxx:$result" - return $argdata_dict - } - - #return raw definition list as created with 'define' - # - possibly with unresolved dynamic parts - proc raw_def {id} { - variable id_cache_rawdef - set realid [real_id $id] - if {![dict exists $id_cache_rawdef $realid]} { - return "" - } - return [tcl::dict::get $id_cache_rawdef $realid] - } - - - namespace eval argdoc { - variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @argdisplay @seealso @leaders @opts @values leaders opts values} - variable resolved_def_TYPE_CHOICEGROUPS { - directives {@id @package @cmd @ref @doc @argdisplay @seealso} - argumenttypes {leaders opts values} - remaining_defaults {@leaders @opts @values} - } - - lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { - @id -id ::punk::args::resolved_def - @cmd -name punk::args::resolved_def -help\ - "Resolves or retrieves the previously resolved definition and - uses the 'spec' form to build a response in definition format. - - Pulling argument definition data from another function is a form - of tight coupling to the other function that should be done with - care. - - Note that the directives @leaders @opts @values may appear multiple - times in a source definition - applying defaults for arguments that - follow. When retrieving these - there is only a single result for - each that represents the defaults after all have been applied. - When retrieving -types * each of these will be positioned before - the arguments of that type - but this doesn't mean there was a single - leading directive for this argument type in the source definition. - Each argument has already had its complete specification recorded in - its own result. - - When manually specifying -types, the order @leaders then @opts then - @values must be maintained - but if they are placed before their - corresponding arguments, they will not affect the retrieved arguments - as these arguments are already fully spec'd. The defaults from the - source can be removed by adding @leaders, @opts @values to the - -antiglobs list, but again - this won't affect the existing arguments. - Each argument can have members of its spec overridden using the - -override dictionary. - " - @leaders -min 0 -max 0 - @opts - -return -default text -choices {text dict} - -form -default 0 -help\ - "Ordinal index or name of command form" - - #no restriction on number of types/repetitions? - -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} - -antiglobs -default {} -type list -help\ - "Glob patterns for directive or argument/flags to - be suppressed" - -override -type dict -optional 1 -default "" -help\ - "dict of dicts. Key in outer dict is the name of a - directive or an argument. Inner dict is a map of - overrides/additions (- ...) for that line. - " - @values -min 1 -max -1 - id -type string -help\ - "identifer for a punk::args definition - This will usually be a fully-qualifed - path for a command name" - pattern -type string -optional 1 -default * -multiple 1 -help\ - "glob-style patterns for retrieving value or switch - definitions. - - If -type is * and pattern is * the entire definition including - directive lines will be returned in line form. - (directives are lines beginning with - @ e.g @id, @cmd etc) - - if -type is leaders,opts or values matches from that type - will be returned. - - if -type is another directive such as @id, @doc etc the - patterns are ignored. - - " - }]] - } - - - proc resolved_def {args} { - #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. - set opts [dict create\ - -return text\ - -types {}\ - -form 0\ - -antiglobs {}\ - -override {}\ - ] - if {[llength $args] < 1} { - #must have at least id - punk::args::parse $args withid ::punk::args::resolved_def - return - } - set patterns [list] - - #a definition id must not begin with "-" ??? review - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {$a in {-type -types}} { - incr i - dict set opts -types [lindex $args $i] - } elseif {[string match -* $a]} { - incr i - dict set opts $a [lindex $args $i] - } else { - set id [lindex $args $i] - set patterns [lrange $args $i+1 end] - break - } - if {$i == [llength $args]-1} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - if {![llength $patterns]} { - set patterns [list *] - } - dict for {k v} $opts { - switch -- $k { - -return - -form - -types - -antiglobs - -override {} - default { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - } - set typelist [dict get $opts -types] - if {[llength $typelist] == 0} { - set typelist {*} - } - foreach type $typelist { - if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - - - variable id_cache_rawdef - set realid [real_id $id] - if {$realid eq ""} { - return - } - - set deflist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] - - set opt_form [dict get $opts -form] - if {[string is integer -strict $opt_form]} { - set formname [lindex [dict get $specdict form_names] $opt_form] - } else { - set formname $opt_form - } - set opt_override [dict get $opts -override] - set opt_return [dict get $opts -return] - - #set arg_info [dict get $specdict ARG_INFO] - set arg_info [dict get $specdict FORMS $formname ARG_INFO] - set argtypes [dict create leaders leader opts option values value] - - set opt_antiglobs [dict get $opts -antiglobs] - set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] - set suppressed_directives [list] - set suppressed_args [list] - foreach ag $opt_antiglobs { - foreach d $directives { - if {[string match $ag $d]} { - lappend suppressed_directives $d - } - } - foreach argname [dict keys $arg_info] { - if {[string match $ag $argname]} { - lappend suppressed_args $argname - } - } - } - set suppressed_directives [lsort -unique $suppressed_directives] - set suppressed_args [lsort -unique $suppressed_args] - - set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] - - set globbed [list] - foreach pat $patterns { - set matches [dict keys $arg_info $pat] - lappend globbed {*}$matches - } - set globbed [lsort -unique $globbed] - set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args] - - set result "" - set resultdict [dict create] - foreach type $typelist { - switch -exact -- $type { - * { - if {"@id" in $included_directives} { - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - foreach directive {@package @cmd @doc @seealso @argdisplay} { - set dshort [string range $directive 1 end] - if {"$directive" in $included_directives} { - if {[dict exists $opt_override $directive]} { - append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict ${dshort}_info]" - dict set resultdict $directive [dict get $specdict ${dshort}_info] - } - } - } - #output ordered by leader, option, value - foreach pseudodirective {leaders opts values} tp {leader option value} { - set directive "@$pseudodirective" - switch -- $directive { - @leaders {set defaults_key leaderspec_defaults} - @opts {set defaults_key optspec_defaults} - @values {set defaults_key valspec_defaults} - } - - if {"$directive" in $included_directives} { - if {[dict exists $opt_override "$directive"]} { - append result \n "$directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict $defaults_key]" - dict set resultdict $directive [dict get $specdict $defaults_key] - } - } - - if {$pseudodirective in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq $tp} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "$m $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - - } - @id { - if {"@id" in $included_directives} { - #only a single id record can exist - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - } - @package - @cmd - @doc - @seealso - @argdisplay { - if {"$type" in $included_directives} { - set tp [string range $type 1 end] ;# @package -> package - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict ${tp}_info]" - dict set resultdict $type [dict get $specdict ${tp}_info] - } - } - } - @leaders - @opts - @values { - #these are the active defaults for further arguments - if {"$type" in $included_directives} { - switch -- $type { - @leaders {set defaults_key leaderspec_defaults} - @opts {set defaults_key optspec_defaults} - @values {set defaults_key valspec_defaults} - } - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict leaderspec_defaults]" - dict set resultdict $type [dict get $specdict leaderspec_defaults] - } - } - } - leaders - opts - values { - #pseudo-directives - if {$type in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "$m $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - default { - } - } - if {$opt_return eq "text"} { - return $result - } else { - return $resultdict - } - } - } - - proc resolved_def_values {id {patternlist *}} { - variable id_cache_rawdef - set realid [real_id $id] - if {$realid ne ""} { - set speclist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [resolve {*}$speclist] - set arg_info [dict get $specdict ARG_INFO] - set valnames [dict get $specdict VAL_NAMES] - set result "" - if {$patternlist eq "*"} { - foreach v $valnames { - set def [dict get $arg_info $v] - set def [dict remove $def -ARGTYPE] - append result \n "$v $def" - } - return $result - } else { - foreach pat $patternlist { - set matches [dict keys $arg_info $pat] - set matches [lsearch -all -inline -glob $valnames $pat] - foreach m $matches { - set def [dict get $arg_info $m] - set def [dict remove $def -ARGTYPE] - append result \n "$m $def" - } - } - return $result - } - } - } - #proc resolved_def_leaders ?? - #proc resolved_def_opts ?? - - proc get_spec {id} { - set rdef [raw_def $id] - if {$rdef eq ""} {return} - return [resolve {*}$rdef] - #if {[id_exists $id]} { - # return [resolve {*}[raw_def $id]] - #} - } - proc is_dynamic {id} { - variable id_cache_rawdef - variable rawdef_cache - set deflist [raw_def $id] - if {[dict exists $rawdef_cache $deflist -dynamic]} { - return [dict get $rawdef_cache $deflist -dynamic] - } - return [rawdef_is_dynamic $deflist] - #@dynamic only has meaning as 1st element of a def in the deflist - } - - #@id must be within first 4 lines of a block - or assign auto - #review - @dynamic block where -id not explicitly set? - disallow? - proc rawdef_id {rawdef} { - set id "" - foreach d $rawdef { - foreach ln [lrange [split $d \n] 0 4] { - if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { - if {$firstword eq "@id"} { - if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { - set id [dict get $rest -id] - break - } - } - } - } - if {$id ne ""} { - break - } - } - if {$id eq "" || [string tolower $id] eq "auto"} { - variable id_counter - set id "autoid_[incr id_counter]" - } - #puts "==>id: $id" - return $id - } - #test the rawdef for @dynamic directive - proc rawdef_is_dynamic {rawdef} { - #temporary - old way - set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] - if {$flagged_dynamic} { - return true - } - foreach d $rawdef { - if {[regexp {\s*(\S+)} $d _match firstword]} { - if {$firstword eq "@dynamic"} { - return true - } - } - } - return false - } - - variable aliases - set aliases [dict create] - - lappend PUNKARGS [list { - @id -id ::punk::args::get_ids - @cmd -name punk::args::get_ids -help\ - "return list of ids for argument definitions" - @values -min 0 -max 1 - match -default * -help\ - "exact id or glob pattern for ids" - }] - proc get_ids {{match *}} { - variable id_cache_rawdef - variable aliases - return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] - } - - #we don't automatically test for (autodef)$id - only direct ids and aliases - proc id_exists {id} { - variable aliases - if {[tcl::dict::exists $aliases $id]} { - return 1 - } - variable id_cache_rawdef - tcl::dict::exists $id_cache_rawdef $id - } - proc set_alias {alias id} { - variable aliases - dict set aliases $alias $id - } - proc unset_alias {alias} { - variable aliases - dict unset aliases $alias - } - proc get_alias {alias} { - variable aliases - if {[dict exists $aliases $alias]} { - return [tcl::dict::get $aliases $alias] - } - } - - proc real_id {id} { - variable id_cache_rawdef - variable aliases - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } else { - set check_updates [list [namespace qualifiers $id]] - if {![llength [update_definitions $check_updates]]} { - #nothing new loaded - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } else { - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } - } - } - - proc status {} { - upvar ::punk::args::register::NAMESPACES registered - upvar ::punk::args::register::loaded_packages loaded_packages - upvar ::punk::args::register::loaded_info loaded_info - upvar ::punk::args::register::scanned_packages scanned_packages - upvar ::punk::args::register::scanned_info scanned_info - set result "" - # [format %-${w0}s $idtail] - set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] - append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n - set width_c2 [string length "Scanned_ids"] - set width_c3 [string length "Scantime_us"] - set width_c4 [string length "Loaded_defs"] - set width_c5 [string length "Loadtime_us"] - set count_unloaded 0 - set count_loaded 0 - foreach ns $registered { - if {$ns in $scanned_packages} { - set ids [dict get $scanned_info $ns idcount] - set scan_us [dict get $scanned_info $ns time] - } else { - set ids "" - set scan_us "" - } - if {$ns in $loaded_packages} { - incr count_loaded - set ldefs [dict get $loaded_info $ns defcount] - set load_us [dict get $loaded_info $ns time] - } else { - incr count_unloaded - set ldefs "" - set load_us "" - } - append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n - } - append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" - return $result - } - - #scanned_packages (list) - #namespace_docpackages (dict) - proc update_definitions {{nslist *}} { - if {[set gposn [lsearch $nslist {}]] >= 0} { - lset nslist $gposn :: - } - upvar ::punk::args::register::NAMESPACES registered ;#list - upvar ::punk::args::register::loaded_packages loaded_packages ;#list - upvar ::punk::args::register::loaded_info loaded_info ;#dict - upvar ::punk::args::register::scanned_packages scanned_packages ;#list - upvar ::punk::args::register::scanned_info scanned_info ;#dict - upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict - - - #puts stderr "-->update_definitions '$nslist'" - #needs to run quickly - especially when no package namespaces to be scanned for argdefs - #e.g - gets called for each subcommand of an ensemble (could be many) - # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. - #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. - # -- --- --- --- --- --- - # common-case fast-path - - if {[llength $loaded_packages] == [llength $registered]} { - #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. - #assert - if all are registered - then all have been scanned ( - return {} - } - # -- --- --- --- --- --- - - set unscanned [punklib_ldiff $registered $scanned_packages] - if {[llength $unscanned]} { - foreach pkgns $unscanned { - set idcount 0 - set ts_start [clock microseconds] - if {[info exists ${pkgns}::PUNKARGS]} { - set seen_documentedns [list] ;#seen per pkgns - foreach definitionlist [set ${pkgns}::PUNKARGS] { - #namespace eval $evalns [list punk::args::define {*}$definitionlist] - set id [rawdef_id $definitionlist] - if {[string match autoid_* $id]} { - puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" - puts stderr "definition:\n" - foreach d $definitionlist { - set out "" - foreach ln [split $d \n] { - append out " " $ln \n - } - puts $out - } - continue - } - #todo - detect duplicate ids (last will silently win.. should be reported somewhere) - incr idcount - set documentedns [namespace qualifiers $id] - if {$documentedns eq ""} {set documentedns ::} - if {$documentedns ni $seen_documentedns} { - #don't add own ns as a key in namespace_docpackages - if {$documentedns ne $pkgns} { - dict lappend namespace_docpackages $documentedns $pkgns - } - lappend seen_documentedns $documentedns - } - } - } - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - dict set scanned_info $pkgns [dict create time $diff idcount $idcount] - #we count it as scanned even if PUNKARGS didn't exist - #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) - lappend scanned_packages $pkgns - } - } - - - - if {"*" in $nslist} { - set needed [punklib_ldiff $registered $loaded_packages] - } else { - set needed [list] - foreach pkgns $nslist { - if {$pkgns in $registered && $pkgns ni $loaded_packages} { - lappend needed $pkgns - } - #argdoc sub namespace is a standard place to put defs that match the namespace below - #(generally the PUNKARGS in a namespace should apply to own ns) - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { - lappend needed $docns - } - } - if {[dict exists $namespace_docpackages $pkgns]} { - #this namespace has other argdef sources - foreach docns [dict get $namespace_docpackages $pkgns] { - if {$docns ni $loaded_packages} { - lappend needed $docns - } - } - } - } - } - - - - set newloaded [list] - foreach pkgns $needed { - #puts stderr "update_definitions Loading: $pkgns" - set ts_start [clock microseconds] - set def_count 0 - if {![catch { - if {[info exists ${pkgns}::PUNKARGS]} { - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - namespace eval ${pkgns}::argdoc { - set epath [namespace path] - set pkgns [namespace parent] - if {$pkgns ni $epath} { - namespace path [list {*}$epath $pkgns] ;#add to tail - } - - } - set evalns $docns - } else { - set evalns $pkgns - } - foreach definitionlist [set ${pkgns}::PUNKARGS] { - namespace eval $evalns [list punk::args::define {*}$definitionlist] - incr def_count - } - } - - #process list of 2-element lists - if {[info exists ${pkgns}::PUNKARGS_aliases]} { - foreach adef [set ${pkgns}::PUNKARGS_aliases] { - punk::args::set_alias {*}$adef - } - } - } errMsg]} { - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - lappend loaded_packages $pkgns - lappend newloaded $pkgns - dict set loaded_info $pkgns [dict create time $diff defcount $def_count] - } else { - puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" - } - } - return $newloaded - } - - #for use within get_dict only - #This mechanism gets less-than-useful results for oo methods - #e.g {$obj} - proc Get_caller {} { - #set call_level -3 ;#for get_dict call - set call_level -4 - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - #puts "-->$cmdinfo" - #puts "-->[tcl::info::frame -3]" - while {[string last \n $cmdinfo] >= 1} { - #looks like a script - haven't gone up far enough? - #(e.g patternpunk oo system: >punk . poses -invalidoption) - incr call_level -1 - if {[catch { - set nextup [tcl::info::frame $call_level] - } ]} { - break - } - set cmdinfo [tcl::dict::get $nextup cmd] - set caller [regexp -inline {\S+} $cmdinfo] - if {[interp alias {} $caller] ne ""} { - #puts "found alias for caller $caller to [interp alias {} $caller]" - #see if we can go further - incr call_level -1 - if {[catch { - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - } errM ]} { - puts "err: $errM" - break - } - } - } - set caller [regexp -inline {\S+} $cmdinfo] - if {$caller eq "namespace"} { - # review - message? - set cmdinfo "punk::args::get_dict called from namespace" - } - return $cmdinfo - } - - - # -------------------------------------- - #test of Get_caller - lappend PUNKARGS [list { - @id -id ::punk::args::test1 - @values -min 0 -max 0 - }] - proc test_get_dict {args} { - punk::args::get_dict {*}[punk::args::raw_def ::punk::args::test1] $args - } - proc test_get_by_id {args} { - punk::args::get_by_id ::punk::args::test1 $args - } - #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. - proc test_callers {args} { - if {![llength $args]} { - puts "these test functions accept no arguments" - puts "Call with arg(s) to compare error output" - } - - if {[catch {test_get_dict {*}$args} errM]} { - puts $errM - } - puts "------------" - if {[catch {test_get_by_id {*}$args} errM]} { - puts $errM - } - return done - } - # -------------------------------------- - - set map "" - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::arg_error - @cmd -name punk::args::arg_error -help\ - "Generates a table (by default) of usage information for a command. - A trie system is used to create highlighted prefixes for command - switches and for subcommands or argument/switch values that accept - a defined set of choices. These prefixes match the mechanism used - to validate arguments (based on tcl::prefix::match). - - This function is called during the argument parsing process - (if the definition is not only being used for documentation) - It is also called by punk::args::usage which is in turn - called by the punk::ns introspection facilities which creates - on the fly definitions for some commands such as ensembles and - oo objects where a manually defined one isn't present. - " - @leaders -min 2 -max 2 - msg -type string -help\ - "Error message to display immediately prior to usage table. - May be empty string to just display usage. - " - spec_dict -type dict -help\ - "Dictionary of argument specifications. - This is the internal format parsed from - the textual definition. It contains the data - organised/optimised to allow the final arg - parser/validator to make decisions. - " - @opts - -badarg -type string -help\ - "name of an argument to highlight" - -aserror -type boolean -help\ - "If true, the usage table is raised as an error message, - otherwise it is returned as a value." - -return -choices {string table tableobject} -choicelabels { - string "no table layout" - tableobject "table object cmd" - table "full table laout" - } - -scheme -choices {nocolour info error} - }] ] - - #basic recursion blocker - variable arg_error_isrunning 0 - proc arg_error {msg spec_dict args} { - #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. - #accept an option here so that we can still use full output for usage requests. - #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args - #Development/experimentation may be done with full table-based error reporting - but for production release it - #may be desirable to reduce overhead on catches. - #consider per-namespace or namespace-tree configurability. - #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due - #to resource availability etc - so the slower error generation time may not always be a problem. - #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling - #code which has no use for the enhanced error info. - #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. - #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system - #todo - #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error - #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) - - #todo - document unnamed leaders and unnamed values where -min and/or -max specified - #e.g punk::args::get_dict {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} {} - #only |?-x?|string|... is shown in the output table. - #should be something like: - # |arg | - # |?-x? | - # |arg | - # |?arg...?| - # Where/how to specify counts? - #also.. - # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? - # - - - if {[catch {package require punk::ansi}]} { - proc punk::args::a {args} {} - proc punk::args::a+ {args} {} - } else { - namespace eval ::punk::args { - namespace import ::punk::ansi::a ::punk::ansi::a+ - } - } - #limit colours to standard 16 so that themes can apply to help output - variable arg_error_isrunning - if {$arg_error_isrunning} { - error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" - } - - if {[llength $args] %2 != 0} { - error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" - } - - set arg_error_isrunning 1 - - set badarg "" - set returntype table ;#table as string - set as_error 1 ;#usual case is to raise an error - set scheme error - dict for {k v} $args { - set fullk [tcl::prefix::match -error "" {-badarg -aserror -return -scheme} $k] - switch -- $fullk { - -badarg { - set badarg $v - } - -aserror { - if {![string is boolean -strict $v]} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" - } - set as_error $v - } - -scheme { - set scheme $v - } - -return { - if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" - } - set returntype $v - } - default { - set arg_error_isrunning 0 - error "arg_error invalid option $k. Known_options: -badarg -return -aserror" - } - } - } - #todo - scheme - use config and iterm toml definitions etc - switch -- $scheme { - "" - -nocolor - -nocolour { - set scheme nocolour - } - info - error {} - default { - set scheme na - } - } - #hack some basics for now. - #for coloured schemes - use bold as well as brightcolour in case colour off. - array set CLR {} - set CLR(errormsg) [a+ brightred] - set CLR(title) "" - set CLR(check) [a+ brightgreen] - set CLR(solo) [a+ brightcyan] - set CLR(choiceprefix) [a+ underline] - set CLR(badarg) [a+ brightred] - set CLR(linebase_header) [a+ white] - set CLR(cmdname) [a+ brightwhite] - set CLR(groupname) [a+ bold] - set CLR(ansiborder) [a+ bold] - set CLR(ansibase_header) [a+ bold] - set CLR(ansibase_body) [a+ white] - - switch -- $scheme { - nocolour { - set CLR(errormsg) [a+ bold] - set CLR(title) [a+ bold] - set CLR(check) "" - set CLR(solo) "" - set CLR(badarg) [a+ reverse] ;#? experiment - set CLR(cmdname) [a+ bold] - set CLR(linebase_header) "" - set CLR(linebase) "" - set CLR(ansibase_body) "" - } - info { - set CLR(errormsg) [a+ brightred bold] - set CLR(title) [a+ brightyellow bold] - set CLR(check) [a+ brightgreen bold] - set CLR(choiceprefix) [a+ brightgreen bold] - set CLR(groupname) [a+ cyan bold] - set CLR(ansiborder) [a+ brightcyan bold] - set CLR(ansibase_header) [a+ cyan] - set CLR(ansibase_body) [a+ white] - } - error { - set CLR(errormsg) [a+ brightred bold] - set CLR(title) [a+ brightcyan bold] - set CLR(check) [a+ brightgreen bold] - set CLR(choiceprefix) [a+ brightgreen bold] - set CLR(groupname) [a+ cyan bold] - set CLR(ansiborder) [a+ brightyellow bold] - set CLR(ansibase_header) [a+ yellow] - set CLR(ansibase_body) [a+ white] - } - na { - } - } - - - #set RST [a] - set RST "\x1b\[m" - set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. - - #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error - #e.g list_as_table - - # use basic colours here to support terminals without extended colours - #todo - add checks column (e.g -minsize -maxsize) - set errmsg $msg - if {![catch {package require textblock}]} { - set has_textblock 1 - } else { - set has_textblock 0 - #couldn't load textblock package - #just return the original errmsg without formatting - } - set use_table 0 - if {$has_textblock && $returntype in {table tableobject}} { - set use_table 1 - } - set errlines [list] ;#for non-textblock output - if {[catch { - if {$use_table} { - append errmsg \n - } else { - if {($returntype in {table tableobject}) && !$has_textblock} { - append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n - } else { - append errmsg \n - } - } - set cmdname [Dict_getdef $spec_dict cmd_info -name ""] - set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] - - set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] - set docurl [Dict_getdef $spec_dict doc_info -url ""] - - set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] - set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] - if {"$argdisplay_header$argdisplay_body" eq ""} { - set is_custom_argdisplay 0 - } else { - set is_custom_argdisplay 1 - } - - - set blank_header_col [list] - if {$cmdname ne ""} { - lappend blank_header_col "" - set cmdname_display $CLR(cmdname)$cmdname$RST - } else { - set cmdname_display "" - } - if {$cmdhelp ne ""} { - lappend blank_header_col "" - #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] - set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] - } else { - set cmdhelp_display "" - } - if {$docurl ne ""} { - lappend blank_header_col "" - set docurl_display [a+ white]$docurl$RST - } else { - set docurl_display "" - } - #synopsis - set synopsis "" - set form_info [dict get $spec_dict FORM_INFO] - dict for {fid finfo} $form_info { - set syn [Dict_getdef $finfo -synopsis ""] - if {$syn ne ""} { - append synopsis $syn \n - } - } - if {$synopsis ne ""} { - set synopsis [string range $synopsis 0 end-1] - lappend blank_header_col "" - } - - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - if {$use_table} { - set t [textblock::class::table new "$CLR(title)Usage$RST"] - $t add_column -headers $blank_header_col -minwidth 3 - $t add_column -headers $blank_header_col - - if {!$is_custom_argdisplay} { - lappend blank_header_col "" - #spanned columns in default argdisplay area - $t add_column -headers $blank_header_col ;#Default - $t add_column -headers $blank_header_col ;#Multi - $t add_column -headers $blank_header_col ;#Help - set arg_colspans {1 4 0 0 0} - } else { - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - set arg_colspans {1 1} - } - } - set h 0 - if {$cmdname ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] - } else { - lappend errlines "COMMAND: $cmdname_display" - } - incr h - } - if {$cmdhelp ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] - } else { - lappend errlines "Description: $cmdhelp_display" - } - incr h - } - if {$docurl ne ""} { - if {![catch {package require punk::ansi}]} { - set docurl [punk::ansi::hyperlink $docurl] - } - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] - } else { - lappend errlines "$docname $docurl_display" - } - incr h - } - if {$synopsis ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Synopsis: $synopsis] - } else { - #todo - lappend errlines "Synopsis:\n$synopsis" - } - incr h - } - - - if {$use_table} { - if {$is_custom_argdisplay} { - if {$argdisplay_header ne ""} { - $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] - } - } else { - $t configure_header $h -values {Arg Type Default Multi Help} - } - } else { - lappend errlines " --ARGUMENTS-- " - } - - if {$is_custom_argdisplay} { - if {$use_table} { - #using overall container table - #header already added - #TODO - review textblock::table features - #we can't currently span columns within the table body. - #This feature could allow hidden data columns (and sort on hidden col?) - #potentially require coordination with header colspans? - $t add_row [list "" $argdisplay_body] - } else { - if {$argdisplay_header ne ""} { - lappend errlines $argdisplay_header - } - lappend errlines {*}$argdisplay_body - } - } else { - - #set A_DEFAULT [a+ brightwhite Brightgreen] - set A_DEFAULT "" - set A_BADARG $CLR(badarg) - set greencheck $CLR(check)\u2713$RST ;#green tick - set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply - if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { - #A_PREFIX can resolve to empty string if colour off - #we then want to display underline instead - set A_PREFIX [a+ underline] - set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space - } else { - set A_PREFIXEND $RST - } - - set opt_names [list] - set opt_names_display [list] - if {[llength [dict get $spec_dict OPT_NAMES]]} { - if {![catch {package require punk::trie}]} { - set trie [punk::trie::trieclass new {*}[dict get $spec_dict OPT_NAMES]] - set idents [dict get [$trie shortest_idents ""] scanned] - #todo - check opt_prefixdeny - - $trie destroy - foreach c [dict get $spec_dict OPT_NAMES] { - set id [dict get $idents $c] - #REVIEW - if {$id eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $id] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail - #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] - lappend opt_names $c - } - } else { - set opt_names [dict get $spec_dict OPT_NAMES] - set opt_names_display $opt_names - } - } - set leading_val_names [dict get $spec_dict LEADER_NAMES] - set trailing_val_names [dict get $spec_dict VAL_NAMES] - - #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { - # if {![string match -* $argname]} { - # lappend leading_val_names [lpop trailing_val_names 0] - # } else { - # break - # } - #} - #if {![llength $leading_val_names] && ![llength $opt_names]} { - # #all vals were actually trailing - no opts - # set trailing_val_names $leading_val_names - # set leading_val_names {} - #} - set leading_val_names_display $leading_val_names - set trailing_val_names_display $trailing_val_names - - #display options first then values - foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { - lassign $argumentset argnames_display argnames - - foreach argshow $argnames_display arg $argnames { - set arginfo [dict get $spec_dict ARG_INFO $arg] - if {[dict exists $arginfo -default]} { - set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" - } else { - set default "" - } - set help [Dict_getdef $arginfo -help ""] - set allchoices_originalcase [list] - set choices [Dict_getdef $arginfo -choices {}] - set choicegroups [Dict_getdef $arginfo -choicegroups {}] - set choicemultiple [dict get $arginfo -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] - set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] - if {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - set is_multiple 1 - } else { - set multiple "" - set is_multiple 0 - } - if {[dict exists $choicegroups ""]} { - dict lappend choicegroups "" {*}$choices - } else { - set choicegroups [dict merge [dict create "" $choices] $choicegroups] - } - dict for {groupname clist} $choicegroups { - lappend allchoices_originalcase {*}$clist - } - set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] - - if {$has_choices} { - if {$help ne ""} {append help \n} - if {[dict get $arginfo -nocase]} { - set casemsg " (case insensitive)" - set allchoices_test [string tolower $allchoices_originalcase] - } else { - set casemsg " (case sensitive)" - set allchoices_test $allchoices_originalcase - } - if {[dict get $arginfo -choiceprefix]} { - set prefixmsg " (choice prefix allowed)" - } else { - set prefixmsg "" - } - set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] - set formattedchoices [dict create] ;#use dict rather than array to preserve order - append help " Choices$prefixmsg$casemsg" - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - if {$choicemultiple_max == -1} { - append help \n " The value can be a list of $choicemultiple_min or more of these choices" - } else { - if {$choicemultiple_min eq $choicemultiple_max} { - append help \n " The value must be a list of $choicemultiple_min of these choices" - } else { - append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" - } - } - } - if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set cdisplay $c - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - dict lappend formattedchoices $groupname $cdisplay - } - } - } else { - set formattedchoices $choicegroups - #set formattedchoices [dict get $arginfo -choices] - } - } else { - if {[catch { - set trie [punk::trie::trieclass new {*}$allchoices_test] - set idents [dict get [$trie shortest_idents ""] scanned] - if {[dict get $arginfo -nocase]} { - #idents were calculated on lcase - remap keys in idents to original casing - set actual_idents $idents - foreach ch $allchoices_originalcase { - if {![dict exists $idents $ch]} { - #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting - #The actual testing is done in get_dict - dict set actual_idents $ch [dict get $idents [string tolower $ch]] - } - } - set idents $actual_idents - #puts "-----" - #puts "idents $idents" - } - - $trie destroy - dict for {groupname clist} $choicegroups { - foreach c $clist { - if {$c in $choiceprefixdenylist} { - set shortestid $c - } else { - set shortestid [dict get $idents $c] - } - if {$shortestid eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $shortestid] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]" - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - dict lappend formattedchoices $groupname $cdisplay - } - } - } errM]} { - #this failure can happen if -nocase is true and there are ambiguous entries - #e.g -nocase 1 -choices {x X} - puts stderr "prefix marking failed\n$errM" - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set cdisplay $c - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - dict lappend formattedchoices $groupname $cdisplay - } - } - } else { - set formattedchoices $choicegroups - } - - } - } - set choicetable_objects [list] - set choicetable_footers [dict create] - dict for {groupname formatted} $formattedchoices { - set numcols $choicecolumns ;#todo - dynamic? - if {[llength $formatted] < $numcols} { - #don't show blank cells if single line of results - set numcols [llength $formatted] - } - if {$numcols > 0} { - if {$use_table} { - #risk of recursing - #TODO -title directly in list_as_table - set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] - lappend choicetable_objects $choicetableobj - $choicetableobj configure -title $CLR(groupname)$groupname - #append help \n[textblock::join -- " " [$choicetableobj print]] - } else { - if {$groupname ne ""} { - append help \n \n "$CLR(groupname)Group: $groupname$RST" - } else { - append help \n - } - append help \n [join $formatted \n] - } - } else { - #we were given an empty set of choices. - #probably an error in the definition - but could happen if dynamically generated. - #(e.g ensemble where unknown mechanism is used for subcommands?) - #better to just display that there were none rather than totally break the usage output. - if {$usetable} { - #these will be displayed after all table entries - if {$groupname eq ""} { - dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" - } else { - dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" - } - } else { - if {$groupname eq ""} { - append help \n " " $CLR(errormsg)(no choices defined)$RST - } else { - append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST - } - } - } - } - set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width - foreach obj $choicetable_objects { - dict lappend twidths_by_colcount [$obj column_count] [$obj width] - } - foreach obj $choicetable_objects { - set cols [$obj column_count] - set widths [dict get $twidths_by_colcount $cols] - set max [tcl::mathfunc::max {*}$widths] - $obj configure -minwidth $max ;#expand smaller ones - set i 0 - while {$i < $cols} { - #keep text aligned left on expanded tables - $obj configure_column $i -blockalign left - incr i - } - - append help \n[textblock::join -- " " [$obj print]] - #set ansititle [dict get [$obj configure -title] value] - $obj destroy - } - if {[dict size $choicetable_footers]} { - foreach groupname [dict keys $formattedchoices] { - if {[dict exists $choicetable_footers $groupname]} { - append help \n [dict get $choicetable_footers $groupname] - } - } - } - - #review. use -type to restrict additional choices - may be different to values in the -choices - if {![dict get $arginfo -choicerestricted]} { - #when -choicemultiple - the -type refers to each selection - if {[dict get $arginfo -type] eq "string"} { - append help "\n (values not in defined choices are allowed)" - } else { - append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" - } - } - } - if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { - if {$is_multiple} { - set argshow "?${argshow}...?" - } else { - set argshow "?${argshow}?" - } - } else { - if {$is_multiple} { - set argshow "${argshow}..." - } - } - set typeshow [dict get $arginfo -type] - if {$typeshow eq "none"} { - set typeshow "$typeshow $soloflag" - } - if {[dict exists $arginfo -minsize]} { - append typeshow \n "-minsize [dict get $arginfo -minsize]" - } - if {[dict exists $arginfo -maxsize]} { - append typeshow \n "-maxsize [dict get $arginfo -maxsize]" - } - if {[dict exists $arginfo -range]} { - append typeshow \n "-range [dict get $arginfo -range]" - } - - if {$use_table} { - $t add_row [list $argshow $typeshow $default $multiple $help] - if {$arg eq $badarg} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG - } - } else { - #review - formatting will be all over the shop due to newlines in typesshow, help - set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" - foreach ln [split $help \n] { - append arghelp " $ln" \n - } - lappend errlines $arghelp - } - } - } - } ;#end is_custom_argdisplay - - if {$use_table} { - $t configure -show_hseps 0\ - -show_header 1\ - -ansibase_body $CLR(ansibase_body)\ - -ansibase_header $CLR(ansibase_header)\ - -ansiborder_header $CLR(ansiborder)\ - -ansiborder_body $CLR(ansiborder) - - $t configure -maxwidth 80 ;#review - if {$returntype ne "tableobject"} { - append errmsg [$t print] - #returntype of table means just the text of the table - $t destroy - } - } else { - append errmsg [join $errlines \n] - } - } errM]} { - catch {$t destroy} - append errmsg \n - append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n - append errmsg "$errM" \n - append errmsg "$::errorInfo" - - } - set arg_error_isrunning 0 - #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. - #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) - if {$use_table} { - #assert returntype is one of table, tableobject - set result $errmsg ;#default if for some reason table couldn't be used - if {$returntype eq "tableobject"} { - if {[info object isa object $t]} { - set result $t - } - } - } else { - set result $errmsg - } - if {$as_error} { - return -code error -errorcode {TCL WRONGARGS PUNK} $result - } else { - return $result - } - } - - - lappend PUNKARGS [list { - @dynamic - @id -id ::punk::args::usage - @cmd -name punk::args::usage -help\ - "Return usage information for a command identified by an id. - - This will only work for commands where a punk::args definition exists - for the command and an id has been defined for it. The id for custom - help for a command should match the fully qualified name of the command. - - Many commands (such as ensembles and oo objects) may have argument - documentation generated dynamically and may not yet have an id. - IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. - - Generally punk::ns::arginfo (aliased as i in the punk shell) should - be used in preference - as it will search for a documentation - mechanism and call punk::args::usage as necessary. - " - -return -default table -choices {string table tableobject} - } {${[punk::args::resolved_def -types opts ::punk::args::arg_error -scheme]}} { - - @values -min 0 -max 1 - id -help\ - "Exact id. - Will usually match the command name" - }] - proc usage {args} { - lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received - set id [dict get $values id] - set real_id [real_id $id] - if {$real_id eq ""} { - error "punk::args::usage - no such id: $id" - } - arg_error "" [punk::args::get_spec $real_id] -scheme punk_info {*}$opts -aserror 0 - } - - lappend PUNKARGS [list { - @id -id ::punk::args::get_by_id - @cmd -name punk::args::get_by_id - @values -min 1 - id - arglist -type list -help\ - "list containing arguments to be parsed as per the - argument specification identified by the supplied id." - }] - - - #deprecate? - proc get_by_id {id arglist} { - set definitionlist [punk::args::raw_def $id] - if {[llength $definitionlist] == 0} { - error "punk::args::get_by_id - no such id: $id" - } - #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] - tailcall ::punk::args::get_dict {*}$definitionlist $arglist - } - - #consider - - #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) - #parse ?-flag val?... -- $arglist withid $id - #parse ?-flag val?... -- $arglist withdef $def ?$def?... - - #an experiment.. ideally we'd like arglist at the end? - #parse_withid ?-flag val?.. $id $arglist - #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? - #no possible equivalent for parse_withdef ??? - - lappend PUNKARGS [list { - @id -id ::punk::args::parse - @cmd -name punk::args::parse -help\ - "parse and validate command arguments based on a definition. - - In the 'withid' form the definition is a pre-existing record that has been - created with ::punk::args::define, or indirectly by adding a definition to - the PUNKARGS variable in a namespace which is then registered in - punk::args::register::NAMESPACES, or by a previous call to punk::parse - using 'withdef' and a definition block containing an @id -id directive. - - In the 'withdef' form - the definition is created on the first call and - cached thereafter, if the id didn't already exist. - - form1: parse $arglist ?-flag val?... withid $id - form2: parse $arglist ?-flag val?... withdef $def ?$def? - see punk::args::define" - @form -form {withid withdef} - @leaders -min 1 -max 1 - arglist -type list -optional 0 -help\ - "Arguments to parse - supplied as a single list" - - @opts - -form -type list -default * -help\ - "Restrict parsing to the set of forms listed. - Forms are the orthogonal sets of arguments a - command can take - usually described in 'synopsis' - entries." - #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance - #todo - configurable per interp/namespace - -errorstyle -type string -default enhanced -choices {enhanced standard minimal} - - @values -min 2 - - @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" - withid -type literal -help\ - "The literal value 'withid'" - id -type string -help\ - "id of punk::args definition for a command" - - - @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" - withdef -type literal -help\ - "The literal value 'withdef'" - - #todo - make -dynamic obsolete - use @dynamic directive instead - def -type string -multiple 1 -optional 0 -help\ - "Each remaining argument is a block of text - defining argument definitions. - As a special case, -dynamic may be - specified as the 1st 2 arguments. These are - treated as an indicator to punk::args about - how to process the definition." - - }] - proc parse {args} { - set tailtype "" ;#withid|withdef - if {[llength $args] < 3} { - error "punk::args::parse - invalid call. < 3 args" - } - set parseargs [lindex $args 0] - set tailargs [lrange $args 1 end] - - set split [lsearch -exact $tailargs withid] - if {$split < 0} { - set split [lsearch -exact $tailargs withdef] - if {$split < 0} { - #punk::args::usage arg_error? - error "punk::args::parse - invalid call. keyword withid|withdef required" - } else { - set tailtype withdef - } - } else { - set tailtype withid - } - - set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. - if {[llength $opts] % 2} { - error "punk::args::parse Even number of -flag val pairs required after arglist" - } - set defaultopts [dict create\ - -form {*}\ - -errorstyle enhanced\ - ] - set opts [dict merge $opts $defaultopts] - dict for {k v} $opts { - switch -- $k { - -form - -errorstyle { - } - default { - #punk::args::usage $args withid ::punk::args::parse ?? - error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" - } - } - } - switch -- $tailtype { - withid { - if {[llength [lrange $tailargs $split+1 end]] != 1} { - error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - } - set id [lindex $tailargs $split+1] - #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" - set deflist [raw_def $id] - if {[llength $deflist] == 0} { - error "punk::args::parse - no such id: $id" - } - } - withdef { - set deflist [lrange $tailargs $split+1 end] - if {[llength $deflist] < 1} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" - } - default { - error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" - } - } - try { - set result [punk::args::get_dict {*}$deflist $parseargs] - } trap {PUNKARGS VALIDATION} {msg opts} { - set opt_errorstyle [dict get $opts -errorstyle] - - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname]] $msg - #set msg "Option $argname for [Get_caller] requires type '$type'. Received: '$e'" - ##try trap? - ##return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type]]] $result - ##throw ? - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname]] $msg - #arg_error $msg $argspecs -badarg $argname - switch -- $opt_errorstyle { - minimal { - return -options [list -code error -errorcode $::errorCode] $::errorInfo - } - standard { - puts stderr "(todo enhanced error) PUNKARGS VALIDATION: $msg\n$opts" - } - enhanced { - puts stderr "(todo enhanced error) PUNKARGS VALIDATION: $msg\n$opts" - } - } - return - } trap {PUNKARGS} {msg opts} { - #trap punk::args argument validation/parsing errors and decide here - #whether to display basic error - or full usage if configured. - puts stderr "PUNKARGS OTHER: $msg\n$opts" - #JJJ - return - } trap {} {msg opts} { - #review - #puts stderr "$msg\n$opts" - #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. - #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. - throw [dict get $opts -errorcode] [dict get $opts -errorinfo] - return - } - return $result - } - proc parseXXX {args} { - #no solo flags allowed for parse function itself. (ok for arglist being parsed) - set opts [dict create] ;#repeated flags will override earlier. That's ok here. - set arglist {} - set got_arglist 0 - set tailtype "" ;#withid|withdef - set id "" - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {[string match -* $a]} { - dict set opts $a [lindex $args $i+1] - incr i - } else { - set arglist $a - set got_arglist 1 - set tailtype [lindex $args $i+1] - if {$tailtype eq "withid"} { - if {[llength $args] != $i+3} { - error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - } - set id [lindex $args $i+2] - break - } elseif {$tailtype eq "withdef"} { - if {[llength $args] < $i+3} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - set deflist [lrange $args $i+2 end] - break - } else { - error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" - } - } - } - if {!$got_arglist} { - error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." - } - #assert tailtype eq withid|withdef - if {$tailtype eq "withid"} { - #assert $id was provided - return "parse [llength $arglist] args withid $id, options:$opts" - } else { - #assert llength deflist >=1 - return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" - } - #TODO - } - - #todo? - a version of get_dict that directly supports punk::lib::tstr templating - #rename get_dict - # - - #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 get_dict {args} { - #see arg_error regarding considerations around unhappy-path performance - - #consider a better API - # - e.g punk::args::parse ?-flag val?... $arglist withid $id - # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? - #can the above be made completely unambiguous for arbitrary arglist?? - #e.g what if arglist = withdef and the first $def is also withdef ? - - - #*** !doctools - #[call [fun get_dict] [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 values - #[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 defining a flag 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 - #[para]Each optionspec line defining a positional argument is of the form: - #[para]argumentname -key val -ky2 val2... - #[para]where the valid keys for each option specification are: -default -type -range -choices - #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value - #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. - #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. - #[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, - #but it could be a manually constructed list of values made for example from positional args defined in the proc. - #[list_end] - #[para] - - #consider line-processing example below for which we need info complete to determine record boundaries - #punk::args::get_dict { - # @opts - # -opt1 -default {} - # -opt2 -default { - # etc - # } - # @values -multiple 1 - #} $args - - set rawargs [lindex $args end] ;# args values to be parsed - #we take a definition list rather than argspecs - because the definition could be dynamic - set definition_args [lrange $args 0 end-1] - - #if definition has been seen before, - #define will either return a permanently cached argspecs (-dynamic 0) - or - # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. - set argspecs [uplevel 1 [list ::punk::args::resolve {*}$definition_args]] - - # ----------------------------------------------- - # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) - tcl::dict::with argspecs {} ;#turn keys into vars - # TODO - capitalise 'define' vars to make it a bit easier - # ----------------------------------------------- - - #puts "-arg_info->$arg_info" - set flagsreceived [list] ;#for checking if required flags satisfied - set solosreceived [list] - #secondary purpose: - #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 ? - - # -- --- --- --- - # Handle leading positionals - # todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ? - set opts $opt_defaults - set pre_values {} - - set argnames [tcl::dict::keys $ARG_INFO] - set optnames [lsearch -all -inline $argnames -*] - set ridx 0 - set rawargs_copy $rawargs - set leader_posn_name "" - set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) - set is_multiple 0 ;#last leader may be multi - if {$LEADER_MAX != 0} { - foreach r $rawargs_copy { - if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { - break - } - if {$ridx == [llength $LEADER_NAMES]-1} { - #at last named leader - set leader_posn_name [lindex $LEADER_NAMES $ridx] - if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { - set is_multiple 1 - } - } elseif {$ridx > [llength $LEADER_NAMES]-1} { - #beyond names - retain name if -multiple was true - if {!$is_multiple} { - set leader_posn_name "" - } - } else { - set leader_posn_name [lindex $LEADER_NAMES $ridx] ;#may return empty string - } - if {$r eq "--"} { - #review end of opts marker: '--' can't be a leader (but can be a value) - break - } - - #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option - if {[tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { - set matchopt [::tcl::prefix::match -error {} $optnames $r] - if {$matchopt ne ""} { - #flaglike matches a known flag - don't treat as leader - break - } - #if {![string match -* [lindex $argnames $ridx]]} {} - if {$leader_posn_name ne ""} { - #there is a named leading positional for this position - #The flaglooking value doesn't match an option - so treat as a leader - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - incr ridx - continue - } else { - break - } - } - - #for each branch - break or lappend - if {$leader_posn_name ne ""} { - if {$leader_posn_name ni $LEADER_REQUIRED} { - #optional leader - - #most adhoc arg processing will allocate based on number of args rather than matching choice values first - #(because a choice value could be a legitimate data value) - - #review - option to process in this manner? - #first check if the optional leader value is a match for a choice ? - #if {[dict exists $arg_info $leader_posn_name -choices]} { - # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] [lindex $rawargs 0]] - # if {$vmatch ne ""} { - # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values - # lappend pre_values [lpop rawargs 0] - # incr ridx - # continue - # } - #} - - #check if enough rawargs to fill any required values - if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { - break - } else { - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #required - if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { - #already accepted at least one value - requirement satisfied - now equivalent to optional - if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { - break - } - } - #if we didn't break - requirement is not yet satisfied, or is satisfied but stil enough rawargs for required values - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #unnamed leader - if {$LEADER_MIN ne "" } { - if {$ridx > $LEADER_MIN} { - break - } else { - #haven't reached LEADER_MIN - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - break - } - } - - incr ridx - } ;# end foreach r $rawargs_copy - } - - set argstate $ARG_INFO ;#argstate may have entries added - set arg_checks $ARG_CHECKS - - if {$LEADER_MIN eq ""} { - set leadermin 0 - } else { - set leadermin $LEADER_MIN - } - if {$LEADER_MAX eq ""} { - set leadermax -1 - } else { - set leadermax $LEADER_MAX - } - - #assert leadermax leadermin are numeric - #assert - rawargs has been reduced by leading positionals - - set leaders [list] - set arglist {} - set post_values {} - #val_min, val_max - #puts stderr "rawargs: $rawargs" - #puts stderr "argstate: $argstate" - if {[lsearch $rawargs -*] >= 0} { - #at least contains flaglike things.. - set maxidx [expr {[llength $rawargs] -1}] - if {$val_max == -1} { - set vals_total_possible [llength $rawargs] - set vals_remaining_possible $vals_total_possible - } else { - set vals_total_possible $val_max - set vals_remaining_possible $vals_total_possible - } - for {set i 0} {$i <= $maxidx} {incr i} { - set a [lindex $rawargs $i] - set remaining_args_including_this [expr {[llength $rawargs] - $i}] - #lowest val_min is 0 - if {$remaining_args_including_this <= $val_min} { - # if current arg is -- it will pass through as a value here - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - - #exlude argument with whitespace from being a possible option e.g dict - if {[tcl::string::match -* $a] && !([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { - if {$a eq "--"} { - #remaining num args <= val_min already covered above - if {$val_max != -1} { - #finite max number of vals - if {$remaining_args_including_this == $val_max} { - #assume it's a value. - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - } else { - #assume it's an end-of-options marker - lappend flagsreceived -- - set arglist [lrange $rawargs 0 $i] - set post_values [lrange $rawargs $i+1 end] - } - } else { - #unlimited number of post_values accepted - #treat this as eopts - we don't care if remainder look like options or not - lappend flagsreceived -- - set arglist [lrange $rawargs 0 $i] - set post_values [lrange $rawargs $i+1 end] - } - break - } else { - set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] - if {$fullopt ne ""} { - if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { - #non-solo - #check if it was actually a value that looked like a flag - if {$i == $maxidx} { - #if no optvalue following - assume it's a value - #(caller should probably have used -- before it) - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - - set flagval [lindex $rawargs $i+1] - if {[tcl::dict::get $argstate $fullopt -multiple]} { - #don't lappend to default - we need to replace if there is a default - if {$fullopt ni $flagsreceived} { - tcl::dict::set opts $fullopt [list $flagval] - } else { - tcl::dict::lappend opts $fullopt $flagval - } - } else { - tcl::dict::set opts $fullopt $flagval - } - #incr i to skip flagval - incr vals_remaining_possible -2 - if {[incr i] > $maxidx} { - arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $fullopt - } - } else { - #solo - if {[tcl::dict::get $argstate $fullopt -multiple]} { - if {$fullopt ni $flagsreceived} { - #override any default - don't lappend to it - tcl::dict::set opts $fullopt 1 - } else { - tcl::dict::lappend opts $fullopt 1 - } - } else { - tcl::dict::set opts $fullopt 1 - } - incr vals_remaining_possible -1 - lapend solosreceived $fullopt - } - lappend flagsreceived $fullopt ;#dups ok - } else { - #unmatched option flag - #comparison to val_min already done above - if {$val_max ne -1 && $remaining_args_including_this <= $val_max} { - #todo - look at optspec_default and see if solo/vs opt-val pair - #we may need to lookahead by 2 regarding val_max val_min - - #even with optany - assume an unknown within the space of possible values is a value - #unmatched option in right position to be considered a value - treat like eopts - #review - document that an unspecified arg within range of possible values will act like eopts -- - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - if {$opt_any} { - set newval [lindex $rawargs $i+1] - #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option - tcl::dict::set argstate $a $optspec_defaults ;#use default settings for unspecified opt - tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS - if {[tcl::dict::get $argstate $a -type] ne "none"} { - if {[tcl::dict::get $argstate $a -multiple]} { - tcl::dict::lappend opts $a $newval - } else { - tcl::dict::set opts $a $newval - } - if {[incr i] > $maxidx} { - arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a - } - incr vals_remaining_possible -2 - } else { - #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none - if {[tcl::dict::get $argstate $a -multiple]} { - if {![tcl::dict::exists $opts $a]} { - tcl::dict::set opts $a 1 - } else { - tcl::dict::lappend opts $a 1 - } - } else { - tcl::dict::set opts $a 1 - } - incr vals_remaining_possible -1 - lappend solosreceived $a - } - lappend flagsreceived $a ;#adhoc flag as supplied - } else { - if {[llength $OPT_NAMES]} { - set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $OPT_NAMES" - } else { - set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": No options defined while @opts -any 0" - } - arg_error $errmsg $argspecs -badarg $fullopt - } - } - } - } else { - #not flaglike - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - } - #set values [list {*}$pre_values {*}$post_values] - set leaders $pre_values - set values $post_values - } else { - set leaders $pre_values - set values $rawargs - #set values [list {*}$pre_values {*}$rawargs] ;#no -flags detected - set arglist [list] - } - #puts stderr "--> arglist: $arglist" - #puts stderr "--> values: $values" - - - set positionalidx 0 ;#index for unnamed positionals (both leaders and values) - set ldridx 0 - set in_multiple "" - set leadernames_received [list] - set leaders_dict $LEADER_DEFAULTS - set num_leaders [llength $leaders] - foreach leadername $LEADER_NAMES ldr $leaders { - if {$ldridx+1 > $num_leaders} { - break - } - if {$leadername ne ""} { - if {[tcl::dict::get $argstate $leadername -multiple]} { - if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { - tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list - } else { - tcl::dict::lappend leaders_dict $leadername $ldr - } - set in_multiple $leadername - } else { - tcl::dict::set leaders_dict $leadername $ldr - } - lappend leadernames_received $leadername - } else { - if {$in_multiple ne ""} { - tcl::dict::lappend leaders_dict $in_multiple $ldr - lappend leadernames_received $in_multiple ;#deliberately allow dups! (as with opts and values) - } else { - tcl::dict::set leaders_dict $positionalidx $ldr - tcl::dict::set argstate $positionalidx $leaderspec_defaults - tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS - lappend leadernames_received $positionalidx - } - } - incr ldridx - incr positionalidx - } - - set validx 0 - set in_multiple "" - set valnames_received [list] - set values_dict $val_defaults - set num_values [llength $values] - foreach valname $VAL_NAMES val $values { - if {$validx+1 > $num_values} { - break - } - if {$valname ne ""} { - if {[tcl::dict::get $argstate $valname -multiple]} { - if {[tcl::dict::exists $val_defaults $valname]} { - #current stored val equals defined default - don't include default in the list we build up - tcl::dict::set values_dict $valname [list $val] ;#important to treat first element as a list - } else { - tcl::dict::lappend values_dict $valname $val - } - set in_multiple $valname - } else { - tcl::dict::set values_dict $valname $val - } - lappend valnames_received $valname - } else { - if {$in_multiple ne ""} { - tcl::dict::lappend values_dict $in_multiple $val - #name already seen - but must add to valnames_received anyway (as with opts and leaders) - lappend valnames_received $in_multiple - } else { - tcl::dict::set values_dict $positionalidx $val - tcl::dict::set argstate $positionalidx $valspec_defaults - tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS - lappend valnames_received $positionalidx - } - } - incr validx - incr positionalidx - } - - if {$leadermax == -1} { - #only check min - if {$num_leaders < $leadermin} { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leadermin" $argspecs - } - } else { - if {$num_leaders < $leadermin || $num_leaders > $leadermax} { - if {$leadermin == $leadermax} { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leadermin" $argspecs - } else { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" $argspecs - } - } - } - - if {$val_max == -1} { - #only check min - if {$num_values < $val_min} { - arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected at least $val_min" $argspecs - } - } else { - if {$num_values < $val_min || $num_values > $val_max} { - if {$val_min == $val_max} { - arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected exactly $val_min" $argspecs - } else { - arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected between $val_min and $val_max inclusive" $argspecs - } - } - } - - #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options - - - #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 SHOULD? 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 - - #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? - #example timing difference: - #struct::set difference {x} {a b} - #normal interp 0.18 u2 vs safe interp 9.4us - #if {[llength [set missing [struct::set difference $opt_required $flagsreceived]]]} { - # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" - #} - #if {[llength [set missing [struct::set difference $val_required $valnames_received]]]} { - # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" - #} - #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us - if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { - arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - if {[llength [set missing [punklib_ldiff $opt_required $flagsreceived]]]} { - arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs - } - if {[llength [set missing [punklib_ldiff $val_required $valnames_received]]]} { - arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - - - #todo - truncate/summarize values in error messages - - #todo - allow defaults outside of choices/ranges - - #check types,ranges,choices - set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] - #set combined_defaults [tcl::dict::merge $val_defaults $opt_defaults] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash - #puts "---opts_and_values:$opts_and_values" - #puts "---argstate:$argstate" - tcl::dict::for {argname v} $opts_and_values { - set thisarg [tcl::dict::get $argstate $argname] - #set thisarg_keys [tcl::dict::keys $thisarg] - set thisarg_checks [tcl::dict::get $arg_checks $argname] - set is_multiple [tcl::dict::get $thisarg -multiple] - set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] - set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] - set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] - set has_default [tcl::dict::exists $thisarg -default] - if {$has_default} { - set defaultval [tcl::dict::get $thisarg -default] - } - set type [tcl::dict::get $thisarg -type] - set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] - set regexprepass [tcl::dict::get $thisarg -regexprepass] - set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 - set validationtransform [tcl::dict::get $thisarg -validationtransform] - - - if {$is_multiple} { - set vlist $v - } else { - set vlist [list $v] - } - set vlist_original $vlist ;#retain for possible final strip_ansi - - #review - validationtransform - if {$is_validate_ansistripped} { - #validate_ansistripped 1 - package require punk::ansi - set vlist_check [list] - foreach e $vlist { - lappend vlist_check [punk::ansi::ansistrip $e] - } - } else { - #validate_ansistripped 0 - set vlist_check $vlist - } - - #reduce our validation requirements by removing values which match defaultval or match -choices - #(could be -multiple with -choicerestriction 0 where some selections match and others don't) - if {$has_choices} { - #-choices must also work with -multiple - #todo -choicelabels - set choiceprefix [tcl::dict::get $thisarg -choiceprefix] - set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] - set choicerestricted [tcl::dict::get $thisarg -choicerestricted] - set choicemultiple [tcl::dict::get $thisarg -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set nocase [tcl::dict::get $thisarg -nocase] - set choices [Dict_getdef $thisarg -choices {}] - set choicegroups [Dict_getdef $thisarg -choicegroups {}] - set allchoices $choices - if {[dict size $choicegroups]} { - dict for {groupname groupmembers} $choicegroups { - lappend allchoices {*}$groupmembers - } - } - #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups - #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes - - - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - set dname leaders_dict - } - option { - set dname opts - } - value { - set dname values_dict - } - } - set idx 0 ;# - #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes - #assert llength $vlist == llength [dict get $dname $argname] - # (unless there was a default and the option wasn't specified) - set vlist_validate [list] - set vlist_check_validate [list] - foreach e $vlist e_check $vlist_check { - set allchoices_in_list 0 - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - #vlist and vlist_check can be list of lists if -multiple and -choicemultiple - #each e represents 0 or more choice selections - set c_list $e - set c_check_list $e_check - #todo? check if entire list matches default? - } else { - #only one choice at a time - ensure single entry in c_list c_check_list - set c_list [list $e] - set c_check_list [list $e_check] - } - - - #----------------------------------- - #fast fail on the wrong number of choices - if {[llength $c_list] < $choicemultiple_min} { - set msg "Option $argname for [Get_caller] requires at least $choicemultiple_min choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { - set msg "Option $argname for [Get_caller] requires at most $choicemultiple_max choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - #----------------------------------- - - set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list - foreach c $c_list c_check $c_check_list { - if {$nocase} { - set casemsg " (case insensitive)" - set choices_test [tcl::string::tolower $allchoices] - #Don't lcase the denylist - even in nocase mode! - #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] - set v_test [tcl::string::tolower $c_check] - } else { - set casemsg " (case sensitive)" - set v_test $c_check - set choices_test $allchoices - } - set choice_in_list 0 - set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? - if {!$matches_default} { - if {$choiceprefix} { - #can we handle empty string as a choice? It should just work - REVIEW/test - set choice_exact_match 0 - if {$c_check in $allchoices} { - #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing - set chosen $c_check - set choice_in_list 1 - set choice_exact_match 1 - } elseif {$v_test in $choices_test} { - #assert - if we're here, nocase must be true - #we know choice is present as full-length match except for case - #now we want to select the case from the choice list - not the supplied value - #we don't set choice_exact_match - because we will need to override the optimistic existing val below - #review - foreach avail [lsort -unique $allchoices] { - if {[string match -nocase $c $avail]} { - set chosen $avail - } - } - #assert chosen will always get set - set choice_in_list 1 - } else { - #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. - #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. - #in this block we can treat empty result from prefix match as a non-match - if {$nocase} { - #nocase implies that our entered value doesn't have to match case of choices - - #but we would still like to select the best match if there are case-dups. - #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete - # selecting Del will find Delete, del will match delete (and raise error) - # but DEL will also match delete rather than Delete - so again an error is raised. - #This is counterintuitive with -nocase - #This is probably such an edge case that best served with documentation as a feature-not-bug - #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? - #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. - - set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] - if {$bestmatch eq ""} { - set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] - #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing - set chosen [lsearch -inline -nocase $allchoices $chosen] - set choice_in_list [expr {$chosen ne ""}] - } else { - set chosen $bestmatch - set choice_in_list 1 - } - } else { - set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] - if {$chosen eq ""} { - set choice_in_list 0 - } else { - set choice_in_list 1 - } - } - #override choice_in_list if in deny list - #don't allow prefixing for elements from -choiceprefixdenylist - #we still use all elements to calculate the prefixes though - #review - case difference edge cases in choiceprefixdenylist !todo - if {$chosen in $choiceprefixdenylist} { - set choice_in_list 0 - set chosen "" - } - } - - #override the optimistic existing val - if {$choice_in_list && !$choice_exact_match} { - if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { - if {$is_multiple} { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $idx $chosen - tcl::dict::set $dname $argname $existing - } else { - tcl::dict::set $dname $argname $chosen - } - } else { - if {$is_multiple} { - set existing_all [tcl::dict::get [set $dname] $argname] - lset existing_all $idx $choice_idx $chosen - tcl::dict::set $dname $argname $existing_all - } else { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $choice_idx $chosen - tcl::dict::set $dname $argname $existing - } - } - } - } else { - #value as stored in $dname is ok - set choice_in_list [expr {$v_test in $choices_test}] - } - } - - if {!$choice_in_list && !$matches_default} { - if {!$choicerestricted} { - #if {$is_multiple} { - # set existing [tcl::dict::get [set $dname] $argname] - # lset existing $idx $v_test - # tcl::dict::set $dname $argname $existing - #} else { - # tcl::dict::set $dname $argname $v_test - #} - lappend vlist_validate $c - lappend vlist_check_validate $c_check - } else { - #unhappy path - if {$choiceprefix} { - set prefixmsg " (or a unique prefix of a value)" - } else { - set prefixmsg "" - } - arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname - } - } - incr choice_idx - } - - incr idx - } - #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation - #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - - if {[llength $vlist] && $has_default} { - set vlist_validate [list] - set vlist_check_validate [list] - foreach c $vlist c_check $vlist_check { - #for -choicemultiple with default that could be a list use 'ni' ?? review - if {$c_check ne $defaultval} { - lappend vlist_validate $c - lappend vlist_check_validate $c - } - } - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - - #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups - #assert: our vlist & vlist_check lists have been reduced to remove those - if {[llength $vlist] && !$is_allow_ansi} { - #allow_ansi 0 - package require punk::ansi - #do not run ta::detect on a list - foreach e $vlist { - if {[punk::ansi::ta::detect $e]} { - error "Option $argname for [Get_caller] contains ansi - but -allow_ansi is false. Received: '$e'" - } - } - } - #puts "argname:$argname v:$v is_default:$is_default" - #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. - #arguments that are at their default are not subject to type and other checks - - #don't validate defaults or choices that matched - #puts "---> opts_and_values: $opts_and_values" - #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" - #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} - - #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups - #assert [llength $vlist] == [llength $vlist_check] - if {[llength $vlist]} { - 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 -badarg $argname - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[llength $e_check] < $checkval} { - arg_error "Option $argname for [Get_caller] requires list with -minsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[llength $e_check] > $checkval} { - arg_error "Option $argname for [Get_caller] requires list with -maxsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - } - } - } - } - } - } - string - ansistring - globstring { - #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string - #we possibly don't want to always have to regex on things that don't pass the other more basic checks - # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) - # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) - # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead - # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function - # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) - # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail - - #todo? - way to validate both unstripped and stripped? - set pass_quick_list_e [list] - set pass_quick_list_e_check [list] - set remaining_e $vlist - set remaining_e_check $vlist_check - #review - order of -regexprepass and -regexprefail in original rawargs significant? - #for now -regexprepass always takes precedence - if {$regexprepass ne ""} { - foreach e $vlist e_check $vlist_check { - if {[regexp $regexprepass $e]} { - lappend pass_quick_list_e $e - lappend pass_quick_list_e_check $e_check - } - } - set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] - set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] - } - if {$regexprefail ne ""} { - foreach e $remaining_e e_check $remaining_e_check { - #puts "----> checking $e vs regex $regexprefail" - if {[regexp $regexprefail $e]} { - if {[tcl::dict::exists $thisarg -regexprefailmsg]} { - set msg [tcl::dict::get $thisarg -regexprefailmsg] - } else { - set msg "Option $argname for [Get_caller] didn't pass regexprefail regex: '$regexprefail' got '$e'" - } - arg_error $msg $argspecs -badarg $argname - } - } - } - switch -- $type { - ansistring { - #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi - #.. so we need to look at the original values in $vlist not $vlist_check - - #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? - #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? - package require punk::ansi - foreach e $remaining_e { - if {![punk::ansi::ta::detect $e]} { - arg_error "Option $argname for [Get_caller] requires ansistring - but no ansi detected" $argspecs -badarg $argname - } - } - } - globstring { - foreach e $remaining_e { - if {![regexp {[*?\[\]]} $e]} { - arg_error "Option $argname for [Get_caller] requires globstring - but no glob characters detected" $argspecs -badarg $argname - } - } - } - } - - if {[tcl::dict::size $thisarg_checks]} { - foreach e_check $remaining_e_check { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[tcl::string::length $e_check] < $checkval} { - arg_error "Option $argname for [Get_caller] requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::string::length $e_check] > $checkval} { - arg_error "Option $argname for [Get_caller] requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - } - } - } - } - } - } - int { - #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive - if {[tcl::dict::exists $thisarg -range]} { - lassign [tcl::dict::get $thisarg -range] low high - if {"$low$high" ne ""} { - if {$low eq ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname - } - #lowside unspecified - check only high - if {$e_check > $high} { - arg_error "Option $argname for [Get_caller] must be integer less than or equal to $high. Received: '$e'" $argspecs -badarg $argname - } - } - } elseif {$high eq ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname - } - #highside unspecified - check only low - if {$e_check < $low} { - arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs -badarg $argname - } - } - } else { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname - } - #high and low specified - if {$e_check < $low || $e_check > $high} { - arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs -badarg $argname - } - } - } - } - } else { - foreach e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e_check'" $argspecs -badarg $argname - } - } - } - } - double { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is double -strict $e_check]} { - error "Option $argname for [Get_caller] requires type 'double'. Received: '$e'" - } - if {[tcl::dict::size $thisarg_checks]} { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -range { - #todo - small-value double comparisons with error-margin? review - #todo - empty string for low or high - lassign $checkval low high - if {$e_check < $low || $e_check > $high} { - arg_error "Option $argname for [Get_caller] must be between $low and $high. Received: '$e'" $argspecs -badarg $argname - } - } - } - } - } - } - } - bool { - foreach e_check $vlist_check { - if {![tcl::string::is boolean -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'boolean'. Received: '$e_check'" $argspecs -badarg $argname - } - } - } - dict { - foreach e_check $vlist_check { - 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 -badarg $argname - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -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 -minsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::dict::size $e_check] > $checkval} { - arg_error "Option $argname for [Get_caller] requires dict with -maxsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - } - } - } - } - } - } - alnum - - alpha - - ascii - - control - - digit - - graph - - lower - - print - - punct - - space - - upper - - wordchar - - xdigit { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is $type $e_check]} { - set msg "Option $argname for [Get_caller] requires type '$type'. Received: '$e'" - #try trap? - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type]]] $result - #throw ? - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname]] $msg - arg_error $msg $argspecs -badarg $argname - } - } - } - file - - directory - - existingfile - - existingdirectory { - foreach e $vlist e_check $vlist_check { - #//review - we may need '?' char on windows - if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { - #what about special file names e.g on windows NUL ? - arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" $argspecs -badarg $argname - } - } - if {$type eq "existingfile"} { - foreach e $vlist e_check $vlist_check { - if {![file exists $e_check]} { - arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing file" $argspecs -badarg $argname - } - } - } elseif {$type eq "existingdirectory"} { - foreach e $vlist e_check $vlist_check { - if {![file isdirectory $e_check]} { - arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing directory" $argspecs -badarg $argname - } - } - } - } - char { - foreach e $vlist e_check $vlist_check { - if {[tcl::string::length $e_check] != 1} { - arg_error "Option $argname for [Get_caller] requires type 'character'. Received: '$e' which is not a single character" $argspecs -badarg $argname - } - } - } - } - - } - - if {$is_strip_ansi} { - set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach - if {[tcl::dict::get $thisarg -multiple]} { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict $argname $stripped_list - } - option { - tcl::dict::set opts $argname $stripped_list - } - value { - tcl::dict::set values_dict $argname $stripped_list - } - } - } else { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict [lindex $stripped_list 0] - } - option { - tcl::dict::set opts $argname [lindex $stripped_list 0] - } - value { - tcl::dict::set values_dict [lindex $stripped_list 0] - } - } - } - } - } - - #maintain order of opts $opts values $values as caller may use lassign. - set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] - if {[llength $receivednames]} { - #flat zip of names with overall posn, including opts - #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] - set i -1 - set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] - } else { - set received_posns [list] - } - #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) - #(e.g using 'dict exists $received -flag') - # - but it can have duplicate keys when args/opts have -multiple 1 - #It is actually a list of paired elements - return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived] - } - - #proc sample1 {p1 args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [opt {?option value...?}]] - # #[para]Description of sample1 - # return "ok" - #} - - - lappend PUNKARGS [list { - @id -id ::punk::args::TEST - @opts -optional 0 - -o1 -default 111 -help "opt 1 mandatory" - @opts -optional 1 - -o2 -default 222 -help "opt 2 optional" - @values -min 0 -max 1 - v -help\ - "v1 optional" - }] - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::lib { - variable PUNKARGS - tcl::namespace::export * - tcl::namespace::path [list [tcl::namespace::parent]] - #*** !doctools - #[subsection {Namespace punk::args::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 flatzip {l1 l2} { - concat {*}[lmap a $l1 b $l2 {list $a $b}] - } - - if {[info commands lseq] ne ""} { - #tcl 8.7+ lseq significantly faster, especially for larger ranges - #The internal rep can be an 'arithseries' with no string representation - proc zero_based_posns {count} { - if {$count < 1} {return} - lseq 0 $count-1 - } - } else { - proc zero_based_posns {count} { - if {$count < 1} {return} - lsearch -all [lrepeat $count 0] * - } - } - - - #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 -1] in calling scope ${[lindex [set x] 0]} !} - lappend PUNKARGS [list { - @id -id ::punk::args::lib::tstr - @cmd -name punk::args::lib::tstr -help\ - "A rough equivalent of js template literals - - Substitutions: - \$\{$varName\} - \$\{[myCommand]\} - (when -allowcommands flag is given)" - -allowcommands -default 0 -type none -help\ - "If -allowcommands is present, placeholder can contain commands - e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" - -undent -default 1 -type boolean -help\ - "undent/dedent the template lines. - The longest common prefix of whitespace is removed" - -indent -default "" -type string -help\ - "String with which to indent the template - prior to substitution. - If -undent is enabled, that is performed - first, then the indent is applied." - -paramindents -default line -choices {none line position} -choicelabels { - line\ - " Use leading whitespace in - the line in which the - placeholder occurs." - position\ - " Use the position in - the line in which the - placeholder occurs." - none\ - " No indents applied to - subsequent placeholder value - lines. This will usually - result in text awkwardly - ragged unless the source code - has also been aligned with the - left margin or the value has - been manually padded." - } -help\ - "How indenting is done for subsequent lines in a - multi-line placeholder substitution value. - The 1st line or a single line value is always - placed at the placeholder. - paramindents are performed after the main - template has been indented/undented. - (indenting by position does not calculate - unicode double-wide or grapheme cluster widths) - " - #choicelabels indented by 1 char is clearer for -return string - and reasonable in table - -return -default string -choices {dict list string args}\ - -choicelabels { - dict\ - " Return a dict with keys - 'template', 'params' and - 'errors'" - string\ - " Return a single result - being the string with - placeholders substituted." - list\ - " Return a 2 element list. - The first is itself a list - of plaintext portions of the - template, split at each point - at which placeholders were - present. The second element - of the outer list is a list - of placeholder values if -eval - is 1, or a list of the raw - placeholder strings if -eval - is 0." - args\ - " Return a list where the first - element is a list of template - plaintext sections as per the - 'list' return mechanism, but the - placeholder items are individual - items in the returned list. - This can be useful when passing - the expanded result of a tstr - command to another function - which expects the placeholders - as individual arguments" - } - -eval -default 1 -type boolean -help\ - "Whether to evaluate the \$\{\} placeholders. - When -return is string, -eval should generally be set to 1. - For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. - contained variables in that case should be braced or whitespace separated, or the variable - name is likely to collide with surrounding text. - e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" - @values -min 0 -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 - e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} - - Escape sequences such as \\n and unicode escapes are processed within placeholders. - " - }] - - proc tstr {args} { - #Too hard to fully eat-our-own-dogfood from within punk::args package - # - we use punk::args within the unhappy path only - #set argd [punk::args::get_by_id ::punk::lib::tstr $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 opt_eval [dict get $argd opts -eval] - - set templatestring [lindex $args end] - set arglist [lrange $args 0 end-1] - set opts [dict create\ - -allowcommands 0\ - -undent 1\ - -indent ""\ - -paramindents line\ - -eval 1\ - -return string\ - ] - if {"-allowcommands" in $arglist} { - set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] - dict set opts -allowcommands 1 - } - if {[llength $arglist] % 2 != 0} { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr expected option/value pairs prior to last argument" - } - } - dict for {k v} $arglist { - set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] - switch -- $fullk { - -indent - -undent - -paramindents - -return - -eval { - dict set opts $fullk $v - } - default { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" - } - } - } - } - set opt_allowcommands [dict get $opts -allowcommands] - set opt_paramindents [dict get $opts -paramindents] - set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] - if {$test_paramindents ni {none line position}} { - error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." - } - set opt_paramindents $test_paramindents - set opt_return [dict get $opts -return] - set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] - if {$opt_return eq ""} { - } - set opt_eval [dict get $opts -eval] - - - set nocommands "-nocommands" - if {$opt_allowcommands == 1} { - set nocommands "" - } - - set opt_undent [dict get $opts -undent] - if {$opt_undent} { - set templatestring [punk::args::lib::undent $templatestring] - } - set opt_indent [dict get $opts -indent] - if {$opt_indent ne ""} { - set templatestring [punk::args::lib::indent $templatestring $opt_indent] - } - - #set parts [_tstr_split $templatestring] - if {[string first \$\{ $templatestring] < 0} { - set parts [list $templatestring] - } else { - set parts [_parse_tstr_parts $templatestring] - } - set textchunks [list] - #set expressions [list] - set params [list] - set idx 0 - set errors [dict create] - set lastline "" ;#todo - first line has placeholder? - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach {pt expression} $parts { - lappend textchunks $pt - incr idx ;#pt incr - - #ignore last expression - if {$idx == [llength $parts]} { - break - } - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - #lappend expressions $expression - #---------------------- - #REVIEW - JMN - #TODO - debug punk::args loading of @dynamic defs - #puts "-- $expression" - #---------------------- - #brk1 - literal newline not {\n} - set leader "" - if {[set brk1 [string first \n $expression]] >= 0} { - #undent left of paramstart only for lines of expression that arent on opening ${..} line - set tail [string range $expression $brk1+1 end] - set leader [string repeat " " [string length $lastline]] - set undentedtail [punk::args::lib::undentleader $tail $leader] - #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] - set expression "[string range $expression 0 $brk1]$undentedtail" - } - if {$opt_eval} { - if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { - lappend params [string cat \$\{ $expression \}] - dict set errors [expr {[llength $params]-1}] $result - } else { - set result [string map [list \n "\n$leader"] $result] - lappend params $result - } - #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] - } else { - lappend params [subst -nocommands -novariables $expression] - } - append lastline [lindex $params end] ;#for current expression's position calc - - incr idx ;#expression incr - } - - if {$opt_return eq "dict"} { - return [dict create template $textchunks params $params errors $errors] - } - if {[dict size $errors]} { - set einfo "" - dict for {i e} $errors { - append einfo "parameter $i error: $e" \n - } - #REVIEW!!! - #TODO - fix - #puts stderr "tstr errors:\n$einfo\n" - } - - switch -- $opt_return { - list { - return [list $textchunks $params] - } - args { - #see example in tstr_test_one - return [list $textchunks {*}$params] - } - string { - #todo - flag to disable indent-matching behaviour for multiline param? - set out "" - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach pt $textchunks param $params { - if {$opt_paramindents eq "none"} { - append out $pt $param - } else { - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - if {$opt_paramindents eq "line"} { - regexp {(\s*).*} $lastline _all lastindent - } else { - #position - #TODO - detect if there are grapheme clusters - #This regsub doesn't properly space unicode double-wide chars or clusters - set lastindent "[regsub -all {\S} $lastline " "] " - } - if {$lastindent ne ""} { - set paramlines [split $param \n] - if {[llength $paramlines] == 1} { - append out $pt $param - } else { - append out $pt [lindex $paramlines 0] - foreach nextline [lrange $paramlines 1 end] { - append out \n $lastindent $nextline - } - } - } else { - append out $pt $param - } - append lastline $param - } - } - return $out - } - } - } - #test single placeholder tstr args where single placeholder must be an int - proc tstr_test_one {args} { - set argd [punk::args::get_dict { - @cmd -name ::punk::args::lib::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 -return args {Select * from table where id = \$\{$id\} and etc... ;}] - } - - @values -min 2 -max 2 - template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - - but the tstr call in the example 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]] ""] - set result [string cat [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 dollar sign - 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]] - } - - #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. - proc indent {text {prefix " "}} { - set result [list] - foreach line [split $text \n] { - if {[string trim $line] eq ""} { - lappend result "" - } else { - lappend result $prefix[string trimright $line] - } - } - return [join $result \n] - } - #dedent? - proc undent {text} { - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - regexp {^([\t ]*)} $lcp _m lcp - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - - #hacky - proc undentleader {text leader} { - #leader usually whitespace - but doesn't have to be - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - lappend nonblank "${leader}!!" - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - #regexp {^([\t ]*)} $lcp _m lcp - #lcp can be shorter than leader - set lcp [string range $lcp 0 [string length $leader]-1] - - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - #A version of textutil::string::longestCommonPrefixList - proc longestCommonPrefix {items} { - if {[llength $items] <= 1} { - return [lindex $items 0] - } - set items [lsort $items[unset items]] - set min [lindex $items 0] - set max [lindex $items end] - #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) - #(sort order nothing to do with length - e.g min may be longer than max) - if {[string length $min] > [string length $max]} { - set temp $min - set min $max - set max $temp - } - set n [string length $min] - set prefix "" - set i -1 - while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { - append prefix $c - } - return $prefix - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] -} - -tcl::namespace::eval punk::args::argdocbase { - namespace export * - #use a? to test and create literal ansi here rather than relying on punk::ansi package presence - #e.g - #% a? bold - #- bold │SGR 1│sample│␛[1msample - #- ──────┼─────┼──────┼────────── - #- RESULT│ │sample│␛[1msample - proc B {} {return \x1b\[1m} ;#a+ bold - proc N {} {return \x1b\[22m} ;#a+ normal - proc I {} {return \x1b\[3m} ;#a+ italic - proc NI {} {return \x1b\[23m} ;#a+ noitalic - -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::package { - variable PUNKARGS - lappend PUNKARGS [list { - @dynamic - @id -id "::punk::args::package::standard_about" - @cmd -name "%pkg%::about" -help\ - "About %pkg% - ... - " - -package_about_namespace -type string -optional 0 -help\ - "Namespace containing the package about procedures - Must contain " - -return\ - -type string\ - -default table\ - -choices {string table tableobject}\ - -choicelabels { - string\ - "A basic text layout" - table\ - "layout in table borders - (requires package: textblock)" - tableobject\ - "textblock::class::table object instance" - }\ - -help\ - "Choose the return type of the 'about' information" - topic -optional 1\ - -nocase 1\ - -default {*}\ - -choices {Description License Version Contact *}\ - -choicerestricted 0\ - -choicelabels { - - }\ - -multiple 1\ - -help\ - "Topic to display. Omit or specify as * to see all. - If * is included with explicit topics, * represents - the remaining unmentioned topics." - }] - proc standard_about {args} { - set argd [punk::args::parse $args withid ::punk::args::package::standard_about] - lassign [dict values $argd] leaders OPTS values received - - set pkgns [dict get $OPTS -package_about_namespace] - if {[info commands ${pkgns}::package_name] eq ""} { - error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" - } - set pkgname [${pkgns}::package_name] - - set opt_return [dict get $OPTS -return] - set all_topics [${pkgns}::about_topics] - if {![dict exists $received topic]} { - set topics $all_topics - } else { - # * represents all remaining topics not explicitly mentioned. - set val_topics [dict get $values topic] ;#if -multiple is true, this is a list - set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] - set topics [list] - foreach t $val_topics { - if {$t eq "*"} { - foreach a $all_topics { - if {$a ni $explicit_topics} { - lappend topics $a - } - } - } else { - lappend topics $t - } - } - } - if {$opt_return ne "string"} { - package require textblock ;#table support - set is_table 1 - set title [string cat {[} $pkgname {]} ] - set t [textblock::class::table new -title $title] - $t configure -frametype double -minwidth [expr {[string length $title]+2}] - - } else { - set topiclens [lmap t $topics {string length $t}] - set widest_topic [tcl::mathfunc::max {*}$topiclens] - set is_table 0 - set about "$pkgname\n" - append about [string repeat - $widest_topic] \n - } - foreach topic $topics { - if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { - set topic_contents [::${pkgns}::get_topic_$topic] - } else { - set topic_contents "" - } - if {!$is_table} { - set content_lines [split $topic_contents \n] - append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n - foreach ln [lrange $content_lines 1 end] { - append about [format %-${widest_topic}s ""] " " $ln \n - } - } else { - $t add_row [list $topic $topic_contents] - } - } - - if {!$is_table} { - return $about - } else { - if {$opt_return eq "tableobject"} { - return $t - } - set result [$t print] - $t destroy - return $result - } - } - -} - -#usually we would directly call arg definitions near the defining proc, -# so that the proc could directly use the definition in its parsing. -# -#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. -#arguably it may be more processor-cache-efficient to do together like this anyway. - -#can't do this here? - as there is circular dependency with punk::lib -#tcl::namespace::eval punk::args { -# foreach deflist $PUNKARGS { -# punk::args::define {*}$deflist -# } -# set PUNKARGS "" -#} - -lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -tcl::namespace::eval punk::args::system { - #*** !doctools - #[subsection {Namespace punk::args::system}] - #[para] Internal functions that are not part of the API - - #dict get value with default wrapper for tcl 8.6 - if {[info commands ::tcl::dict::getdef] eq ""} { - proc Dict_getdef {dictValue args} { - set keys [lrange $args 0 end-1] - if {[tcl::dict::exists $dictValue {*}$keys]} { - return [tcl::dict::get $dictValue {*}$keys] - } else { - return [lindex $args end] - } - } - } else { - #we pay a minor perf penalty for the wrap - interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef - } - - #name to reflect maintenance - home is punk::lib::ldiff - proc punklib_ldiff {fromlist removeitems} { - if {[llength $removeitems] == 0} {return $fromlist} - set result {} - foreach item $fromlist { - if {$item ni $removeitems} { - lappend result $item - } - } - return $result - } - -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::args [tcl::namespace::eval punk::args { - tcl::namespace::path {::punk::args::lib ::punk::args::system} - variable pkg punk::args - variable version - set version 0.1.1 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.4.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.4.tm deleted file mode 100644 index e1256fe4..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.4.tm +++ /dev/null @@ -1,5502 +0,0 @@ -# -*- 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: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.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 punk::args 0.1.4 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.1.4] -#[copyright "2024"] -#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] -#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] -#[require punk::args] -#[keywords module proc args arguments parse] -#[description] -#[para]Utilities for parsing proc args - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). -#[para] overview of punk::args -#[subsection Concepts] -#[para]There are 2 main conventions for parsing a proc args list -#[list_begin enumerated] -#[enum] -#[para]leading option-value pairs and flags followed by a list of values (Tcl style) -#[enum] -#[para]leading list of values followed by option-value pairs and flags (Tk style) -#[list_end] -#[para]There are exceptions in both Tcl and Tk commands regarding this ordering -#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style -#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] -#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. -#[para] -#[para]The basic principle is that a call to punk::args::get_dict is made near the beginning of the proc with a cacheable first argument defining the parameters e.g -#[example { -# proc dofilestuff {args} { -# lassign [dict values [punk::args::get_dict { -# @cmd -help "do some stuff with files e.g dofilestuff " -# @opts -type string -# #comment lines ok -# -directory -default "" -# -translation -default binary -# #setting -type none indicates a flag that doesn't take a value (solo flag) -# -nocomplain -type none -# @values -min 1 -max -1 -# } $args]] leaders opts values -# -# puts "translation is [dict get $opts -translation]" -# foreach f [dict values $values] { -# puts "doing stuff with file: $f" -# } -# } -#}] -#[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls -#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values -#[para]valid @ lines being with @cmd @leaders @opts @values -#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. -#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. -#[para]e.g the result from the punk::args call above may be something like: -#[para] opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} -#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments -#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments -#[example { -# proc dofilestuff {category args} { -# lassign [dict values [punk::args::get_dict { -# -directory -default "" -# -translation -default binary -# -nocomplain -type none -# @values -min 2 -max 2 -# fileA -type existingfile 1 -# fileB -type existingfile 1 -# } $args]] leaders opts values -# puts "$category fileA: [dict get $values fileA]" -# puts "$category fileB: [dict get $values fileB]" -# } -#}] -#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 -#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored -#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, -#[para] or an additional call could be made to punk::args e.g -#[example { -# punk::args::get_dict { -# category -choices {cat1 cat2 cat3} -# another_leading_arg -type boolean -# } [list $category $another_leading_arg] -#}] - -#*** !doctools -#[subsection Notes] -#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. -#[para] -#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. -#For functions that are part of an API a package may be more suitable. -#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) -#[example { -# proc test_switch {args} { -# set opts [dict create\\ -# -return "object"\\ -# -frametype "heavy"\\ -# -show_edge 1\\ -# -show_seps 0\\ -# -x a\\ -# -y b\\ -# -z c\\ -# -1 1\\ -# -2 2\\ -# -3 3\\ -# ] -# foreach {k v} $args { -# switch -- $k { -# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { -# dict set opts $k $v -# } -# default { -# error "unrecognised option '$k'. Known options [dict keys $opts]" -# } -# } -# } -# return $opts -# } -#}] -#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. -#[para] -# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. -# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. -#[para]use punk::lib::show_jump_tables to verify that a jump table exists. -#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous -#[example { -# proc test_prefix {args} { -# set opts [dict create\ -# -return string\ -# -frametype \uFFEF\ -# -show_edge \uFFEF\ -# -show_seps \uFFEF\ -# -x a\ -# -y b\ -# -z c\ -# -1 1\ -# -2 2\ -# -3 3\ -# ] -# if {[llength $args]} { -# set knownflags [dict keys $opts] -# } -# foreach {k v} $args { -# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v -# } -# return $opts -# } -#}] -#[para]There are many alternative args parsing packages a few of which are listed here. -#[list_begin enumerated] -#[enum]argp (pure tcl) -#[enum]parse_args (c implementation) -#[enum]argparse (pure tcl *) -#[enum]cmdline (pure tcl) -#[enum]opt (pure tcl) distributed with Tcl but considered deprecated -#[enum]The tcllib set of TEPAM modules (pure tcl) -#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. -#[list_end] -#[para] (* c implementation planned/proposed) -#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. -#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences -#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. -#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. -#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. -#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. -#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -#All ensemble commands are slower in a safe interp as they aren't compiled the same way -#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 -#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. -#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) -#ensembles: array binary clock dict info namespace string -#possibly file too, although that is generally hidden/modified in a safe interp -#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc -#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::args -#[list_begin itemized] -package require Tcl 8.6- -#optional? punk::trie -#optional? punk::textblock -#*** !doctools -#[item] [package {Tcl 8.6-}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -tcl::namespace::eval punk::args::register { - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] cooperative namespace punk::args::register - #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded - #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. - #[list_begin definitions] - - #Although the actual punk::args::define calls are not too sluggish, there could be *many*. - #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, - #especially since a fair proportion may be for documentation purposes rather than parsing args. - - # -- --- --- --- --- --- --- --- - #cooperative with packages that define some punk args but do so lazily - #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first - variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective - if {![info exists ::punk::args::register::NAMESPACES]} { - set ::punk::args::register::NAMESPACES [list] - } - # -- --- --- --- --- --- --- --- - - variable loaded_packages [list] ;#fully loaded - variable loaded_info [dict create] ;#time - variable scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages - variable scanned_info [dict create] ;#time and idcount - #some packages, e.g punk::args::tclcore document other namespaces. - #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources - variable namespace_docpackages [dict create] - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::register ---}] -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args { - - - variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. - - tcl::namespace::export {[a-z]*} - variable rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} - variable id_cache_rawdef [tcl::dict::create] - variable id_cache_spec [tcl::dict::create] - - variable argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) - - variable argdata_cache [tcl::dict::create] - - variable id_counter 0 - - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] Core API functions for punk::args - #[list_begin definitions] - - #todo - some sort of punk::args::cherrypick operation to get spec from an existing set - #todo - doctools output from definition - - - - - #todo? -synonym/alias ? (applies to opts only not values) - #e.g -background -aliases {-bg} -default White - #review - how to make work with trie prefix - #e.g - # -corner -aliases {-corners} - # -centre -aliases {-center -middle} - #We mightn't want the prefix to be longer just because of an alias - #we should get -co -ce and -m from the above as abbreviations - - set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] - - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::define - #todo @preamble -help "move large block outside of table?" - @cmd -name punk::args::define -help\ - "Accepts a line-based definition of command arguments. - Returns a dictionary representing the argument specifications. - - The return result can generally be ignored, as the record is stored keyed on the - @id -id value from the supplied definition. - This specifications dictionary is structured for (optional) use within commands to - parse and validate the arguments - and is also used when retrieving definitions - (or parts thereof) for re-use. - - This can be used purely for documentation or called within a function to parse a mix - of leading values, switches/flags and trailing values. - - The overhead is favourably comparable with other argument processors - but none are - as fast as minimal code with a switch statement. For toplevel commands where a few - 10s of microseconds is immaterial, the validation and automated error formatting in - a table can be well worthwhile. For inner procs requiring utmost speed, the call can - be made only on the unhappy path when basic processing determines a mismatch - or it - can be left entirely as documentation for interactive use with: i ... - - The definition should usually contain an initial line of the form: @id -id ::somecmd - - Blank lines are ignored at the top level, ie if they are not part of another structure. - Similarly - lines at the top level begginning with the # character are ignored. - All other toplevel lines must consist of a leading word followed by paired arguments. - The arguments can be spread over multiple lines and contain lines of near-arbitrary - text if they are properly braced or double quoted and Tcl escaping for inner quotes - or unbalanced braces is maintained. - The line continuation character - (\\ at the end of the line) can be used to continue the set of arguments for - a leading word. - Leading words beginning with the @ character are directives controlling argument - parsing and help display. - directives include: - %B%@id%N% ?opt val...? - spec-options: -id - %B%@cmd%N% ?opt val...? - spec-options: -name -help - %B%@leaders%N% ?opt val...? - spec-options: -min -max - (used for leading args that come before switches/opts) - %B%@opts%N% ?opt val...? - spec-options: -any - %B%@values%N% ?opt val...? - spec-options: -min -max - (used for trailing args that come after switches/opts) - %B%@argdisplay%N% ?opt val...? - spec-options: -header (text for header row of table) - -body (text to replace autogenerated arg info) - %B%@doc%N% ?opt val...? - spec-options: -name -url - %B%@seealso%N% ?opt val...? - spec-options: -name -url (for footer - unimplemented) - - Some other spec-options normally present on custom arguments are available - to use with the @leaders @opts @values directives to set defaults - for subsequent lines that represent your custom arguments. - These directives should occur in exactly this order - but can be - repeated with custom argument lines interspersed. - - An @id line can only appear once and should be the first item. - For the commandline usage to be displayed either on parsing error - or using the i .. function - an @id with -id is needed. - - All directives can be omitted, in which case every line represents - a custom leader, value or option. - All will be leaders by default if no options defined. - If options are defined (by naming with leading dash, or explicitly - specifying @opts) then the definitions prior to the options will be - categorised as leaders, and those following the options will be - categorised as values. - - Custom arguments are defined by using any word at the start of a - line that doesn't begin with @ or - - (except that adding an additionl @ escapes this restriction so - that @@somearg becomes an argument named @somearg) - - custom leading args, switches/options (names starting with -) - and trailing values also take spec-options: - - -type - defaults to string. If no other restrictions - are specified, choosing string does the least validation. - recognised types: - none - (used for switches only. Indicates this is - a 'solo' flag ie accepts no value) - int|integer - list - dict - double - bool|boolean - char - file - directory - string - ansistring - globstring - (any of the types accepted by 'string is') - - These all perform some validation checks - - and more.. (todo - document here) - - -optional - (defaults to true for flags/switches false otherwise) - For non flag/switch arguments - all arguments with - -optional true must sit consecutively within their group. - ie all optional leader arguments must be together, and all - optional value arguments must be together. Furthermore, - specifying both optional leaders and optional values will - often lead to ambiguous parsing results. Currently, all - optional non-flg/switch arguments should be either at the - trailing end of leaders or the trailing end of values. - Further unambiguous arrangements of optional args may be - made in future - but are currently considered 'unsupported' - -default - -multiple (for leaders & values defines whether - subsequent received values are stored against the same - argument name - only applies to final leader OR final value) - (for options/flags this allows the opt-val pair or solo - flag to appear multiple times - not necessarily contiguously) - -choices {} - A list of allowable values for an argument. - The -default value doesn't have to be in the list. - If a -type is specified - it doesn't apply to choice members. - It will only be used for validation if the -choicerestricted - option is set to false. - -choicerestricted - Whether values not specified in -choices or -choicegroups are - allowed. Defaults to true. - -choiceprefix - This specifies whether unique prefixes are able to be used - instead of the complete string. This is calculated using - tcl::prefix::match - and will display in the autogenerated - usage output. Defaults to true. - -choiceprefixdenylist {} - These choices should match exactly a choice entry in one of - the settings -choices or -choicegroups. - These will still be used in prefix calculation - but the full - choice argument must be entered to select the choice. - -choicegroups {} - Generally this would be used instead of -choices to allow - usage display of choices grouped by some name. - See for example the output if 'i zlib' where choices of the - next subcommand are grouped by the names compression,channel, - streaming and checksumming. The -choices list is equivalent - to a -choicegroups dict entry where the key (groupname) is - the empty string. - -choicemultiple (default {1 1}) - is a pair representing min and max number of choices - that can be present in the value. - If is a single integer it is equivalent to a - specified with the same integer for both min and max. - Max of -1 represents no upper limit. - If allows more than one choice the value is a list - consisting of items in the choices made available through - entries in -choices/-choicegroups. - -minsize (type dependant) - -maxsize (type dependant) - -range (type dependant) - - - " - -dynamic -type boolean -default 0 -help\ - "If -dynamic is true, tstr interpolations of the form \$\{\$var\} - are re-evaluated on each call. - If the definition is being used not just as documentation, but is also - used within the function to parse args, e.g using punk::args::get_by_id, - then it should be noted that there is a slight performance penalty for the - dynamic case. - It is often not significant, perhaps depending on what vars/commands are - used but -dynamic true might be less desirable if the command is used in - inner loops in more performance-sensitive code. - " - @values -min 1 -max -1 - text -type string -multiple 1 -help\ - "Block(s) of text representing the argument definition for a command. - At least one must be supplied. If multiple, they are joined together with \\n. - Using multiple text arguments may be useful to mix curly-braced and double-quoted - strings to have finer control over interpolation when defining arguments. - (this can also be handy for sections that pull resolved definition lines - from existing definitions (by id) for re-use of argument specifications and help text) - - e.g the following definition passes 2 blocks as text arguments - definition { - @id -id ::myns::myfunc - @cmd -name myns::myfunc -help\\ - \"Description of command\" - - #The following option defines an option-value pair - -option1 -default blah -type string - #The following option defines a flag style option (solo) - -flag1 -default 0 -type none -help\\ - \"Info about flag1 - subsequent help lines auto-dedented by whitespace to left - of corresponding record start (in this case -flag1) - + first 4 spaces if they are all present. - This line has no extra indent relative to first line 'Info about flag1' - This line indented a further 6 chars\" - - @values -min 1 -max -1 - #Items that don't begin with * or - are value definitions - v1 -type integer -default 0 - thinglist -type string -multiple 1 - } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" - " - }]] - - proc New_command_form {name} { - #probably faster to inline a literal dict create in the proc than to use a namespace variable - set leaderspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - set optspec_defaults [tcl::dict::create\ - -type string\ - -optional 1\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - set valspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - - #form record can have running entries such as 'argspace' that aren't given to arg parser - #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict - return [dict create\ - argspace "leaders"\ - ARG_INFO [tcl::dict::create]\ - ARG_CHECKS [tcl::dict::create]\ - LEADER_DEFAULTS [tcl::dict::create]\ - LEADER_REQUIRED {}\ - LEADER_NAMES {}\ - LEADER_MIN ""\ - LEADER_MAX ""\ - leaderspec_defaults $leaderspec_defaults\ - LEADER_CHECKS_DEFAULTS {}\ - opt_default {}\ - opt_required {}\ - OPT_NAMES {}\ - opt_any {}\ - opt_solos {}\ - optspec_defaults $optspec_defaults\ - OPT_CHECKS_DEFAULTS {}\ - val_defaults {}\ - val_required {}\ - VAL_NAMES {}\ - val_min ""\ - val_max ""\ - valspec_defaults $valspec_defaults\ - VAL_CHECKS_DEFAULTS {}\ - argdisplay_info ""\ - ] - - #set argdata_dict [tcl::dict::create\ - # id $DEF_definition_id\ - # arg_info $arg_info\ - # arg_checks $arg_checks\ - # leader_defaults $leader_defaults\ - # leader_required $leader_required\ - # leader_names $leader_names\ - # leader_min $leader_min\ - # leader_max $leader_max\ - # leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ - # leader_checks_defaults $leader_checks_defaults\ - # opt_defaults $opt_defaults\ - # opt_required $opt_required\ - # opt_names $opt_names\ - # opt_any $opt_any\ - # opt_solos $opt_solos\ - # optspec_defaults [dict get $F $firstformid optspec_defaults]\ - # opt_checks_defaults $opt_checks_defaults\ - # val_defaults $val_defaults\ - # val_required $val_required\ - # val_names $val_names\ - # val_min $val_min\ - # val_max $val_max\ - # valspec_defaults [dict get $F $firstformid valspec_defaults]\ - # val_checks_defaults $val_checks_defaults\ - # cmd_info $cmd_info\ - # doc_info $doc_info\ - # argdisplay_info $argdisplay_info\ - # id_info $id_info\ - # form_defs $F\ - #] - } - - proc errorstyle {args} { - #set or query the running config -errorstyle - #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? - #values: - #debug, enhanced, standard, basic, minimal - error todo - } - proc define {args} { - dict get [resolve {*}$args] id - } - proc resolve {args} { - variable rawdef_cache - variable id_cache_rawdef - if {[dict exists $rawdef_cache $args]} { - set id [dict get $rawdef_cache $args -id] - set is_dynamic [dict get $rawdef_cache $args -dynamic] - } else { - set id [rawdef_id $args] - set is_dynamic [rawdef_is_dynamic $args] - dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] - dict set id_cache_rawdef $id $args - } - - - variable argdata_cache - variable argdefcache_unresolved - - - set cache_key $args - #ideally we would use a fast hash algorithm to produce a short key with low collision probability. - #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) - #review - check if there is a built-into-tcl way to do this quickly - #for now we will just key using the whole string - #performance seems ok - memory usage probably not ideal - #quote from DKF 2021 - #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. - #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. - #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. - #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). - #> If dealing with very large amounts of data, using a database is probably a good plan. - - set textargs $args - if {![llength $args]} { - punk::args::get_by_id ::punk::args::define {} - return - } - if {[lindex $args 0] eq "-dynamic"} { - set is_dynamic [lindex $args 1] - set textargs [lrange $args 2 end] - } - - if {!$is_dynamic} { - if {[tcl::dict::exists $argdata_cache $cache_key]} { - return [tcl::dict::get $argdata_cache $cache_key] - } - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - if {[string first \$\{ $optionspecs] > 0} { - set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } - } else { - #we are always doing our first subst during the define.. shouldn't it be a separate resolve somehow? optionally so at least? - - if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { - set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel 1 [list ::subst $param]] - } - } else { - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) - if {[string first \$\{ $optionspecs] > 0} { - set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel 1 [list ::subst $param]] - } - tcl::dict::set argdefcache_unresolved $cache_key $pt_params - } - } - #argdata_cache should be limited in some fashion or will be a big memory leak??? - if {[tcl::dict::exists $argdata_cache $optionspecs]} { - #resolved cache version exists - return [tcl::dict::get $argdata_cache $optionspecs] - } - } - - - - #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices - #default to 1 for convenience - - #checks with no default - #-minsize -maxsize -range - - - #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi - #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist - set opt_required [list] - set val_required [list] - - set opt_defaults [tcl::dict::create] - - set val_defaults [tcl::dict::create] - set opt_solos [list] - #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end - - set records [list] - set linebuild "" - - set linelist [split $optionspecs \n] - set lastindent "" - foreach ln $linelist { - if {[tcl::string::trim $ln] eq ""} {continue} - regexp {(\s*).*} $ln _all lastindent - break ;#break at first non-empty - } - #puts "indent1:[ansistring VIEW $lastindent]" - set in_record 0 - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - foreach rawline $linelist { - set recordsofar [tcl::string::cat $linebuild $rawline] - #ansi colours can stop info complete from working (contain square brackets) - #review - when exactly are ansi codes allowed/expected in record lines. - # - we might reasonably expect them in default values or choices or help strings - # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. - # - eg set line "set x \"a[a+ red]red[a]\"" - # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket - if {$has_punkansi} { - set test_complete [punk::ansi::ansistrip $recordsofar] - } else { - #review - #we only need to strip enough to stop interference with 'info complete' - set test_complete [string map [list \x1b\[ ""] $recordsofar] - } - if {![tcl::info::complete $test_complete]} { - #append linebuild [string trimleft $rawline] \n - if {$in_record} { - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. - #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. - #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. - #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) - #(note string first "" $str is fast and returns -1) - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline \n - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline \n - } else { - append linebuild $rawline \n - } - } else { - set in_record 1 - regexp {(\s*).*} $rawline _all lastindent - #puts "indent: [ansistring VIEW -lf 1 $lastindent]" - #puts "indent from rawline:$rawline " - append linebuild $rawline \n - } - } else { - set in_record 0 - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline - } else { - append linebuild $rawline - } - lappend records $linebuild - set linebuild "" - } - } - set cmd_info {} - set package_info {} - set id_info {} ;#e.g -children ?? - set doc_info {} - set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table - set seealso_info {} - set keywords_info {} - ###set leader_min 0 - ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit - #set leader_max "" - #(common case of no leaders specified) - set opt_any 0 - set val_min 0 - set val_max -1 ;#-1 for no limit - set DEF_definition_id $id - - #form_defs - set F [dict create _default [New_command_form _default]] - set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under - - #set ARGSPACE [dict create] ;#keyed on form - #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values - - set refs [dict create] - set record_type "" - set record_number -1 ;# - foreach rec $records { - set trimrec [tcl::string::trim $rec] - switch -- [tcl::string::index $trimrec 0] { - "" - # {continue} - } - incr record_number - set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict - if {[llength $record_values] % 2 != 0} { - #todo - avoid raising an error - store invalid defs keyed on id - error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" - } - # ---------------------------------------------------------- - # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. - #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! - #(form_ids_active is otherwise set in the @form handling block) - - #consider the following 2 line entry which is potentially dynamically included via a tstr: - # @form -form {* newform} - # @form -form {newform} -synopsis "cmd help ?stuff?" - #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. - #(because _default is usually 'taken over' by the first encountered form id) - #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record - #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. - - if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { - set patterns [dict get $record_values -form] - set record_form_ids [list] - foreach p $patterns { - if {[regexp {[*?\[\]]} $p]} { - #isglob - only used for matching existing forms - lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] - } else { - #don't test for existence - will define new form if necessary - lappend record_form_ids $p - } - } - #-form values could be globs that didn't match. record_form_ids could be empty.. - if {[llength $record_form_ids]} { - #only rename _default if it's the sole entry - if {[dict size $F] == 1 && [dict exists $F "_default"]} { - if {"_default" ni $record_form_ids} { - #only initial form exists - but we are mentioning new ones - #first rename the _default to first encountered new form id - #(just replace whole dict with new key - same data) - set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] - #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F - #we are only setting active because of the rename - @form is the way to change active forms list - set form_ids_active [lindex $record_form_ids 0] - } - } - foreach fid $record_form_ids { - if {![dict exists $F $fid]} { - if {$firstword eq "@form"} { - #only @form directly supplies keys - dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] - } else { - dict set F $fid [New_command_form $fid] - } - } else { - #update form with current record opts, except -form - if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } - } - } - } - } else { - #missing or empty -form - set record_form_ids $form_ids_active - if {$firstword eq "@form"} { - foreach fid $form_ids_active { - dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] - } - } - } - # ---------------------------------------------------------- - - set firstchar [tcl::string::index $firstword 0] - set secondchar [tcl::string::index $firstword 1] - if {$firstchar eq "@" && $secondchar ne "@"} { - set record_type "directive" - set directive_name $firstword - set at_specs $record_values - - switch -- [tcl::string::range $directive_name 1 end] { - dynamic { - set is_dynamic 1 - } - id { - #disallow duplicate @id line ? - #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) - - #id An id will be allocated if no id line present or the -id value is "auto" - - if {[dict exists $at_specs -id]} { - set thisid [dict get $at_specs -id] - if {$thisid ni [list $id auto]} { - error "punk::args::define @id mismatch existing: $id vs $thisid" - } - } - set id_info $at_specs - } - ref { - #a reference within the definition - #e.g see punk::args::tclcore ::after - #global reference dict - independent of forms - #ignore refs without an -id - #store all keys except -id - #complete overwrite if refid repeated later on - if {[dict exists $at_specs -id]} { - dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] - } - } - default { - #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple - #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) - #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) - #That is possibly too complicated and/or unnecessary? - #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? - - if {[dict exists $at_specs -id]} { - set copyfrom [get_spec [dict get $at_specs -id]] - #we don't copy the @id info from the source - #for now we only copy across if nothing set.. - #todo - bring across defaults for empty keys at targets? - #need to keep it simple enough to reason about behaviour easily.. - if {[dict size $copyfrom]} { - if {![dict size $cmd_info]} { - set cmd_info [dict get $copyfrom cmd_info] - } - if {![dict size $doc_info]} { - set doc_info [dict get $copyfrom doc_info] - } - foreach fid $record_form_ids { - #only use elements with matching form id? - #probably this feature mainly useful for _default anyway so that should be ok - #cooperative doc sets specified in same file could share via known form ids too - #todo argdisplay_info by fid - if {![dict size $argdisplay_info]} { - set argdisplay_info [dict get $copyfrom argdisplay_info] - } - #TODO - #create leaders opts vals depending on position of @default line? - #options on @default line to exclude/include sets??? - } - } - } - } - form { - # arity system ? - #handle multiple parsing styles based on arities and keyword positions (and/or flags?) - #e.g see lseq manual with 3 different parsing styles. - #aim to produce a table/subtable for each - # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ - # -arities { - # 2 - # {3 anykeys {1 .. 1 to}} - # {4 anykeys {3 by}} - # {5 anykeys {1 .. 1 to 3 by}} - # }\ - # -fallback 1 - # ... - # @parser -synopsis "start 'count' count ??'by'? step?"\ - # -arities { - # {3 anykeys {1 count}} - # } - # ... - # @form -synopsis "count ?'by' step?"\ - # -arities { - # 1 - # {3 anykeys {1 by}} - # } - # - # see also after manual - # @form -arities {1} - # @form -arities { - # 1 anykeys {0 info} - # } - #todo - - #can we generate a form synopsis if -synopsis not supplied? - - #form id can be list of ints|names?, or * - if {[dict exists $at_specs -form]} { - set idlist [dict get $at_specs -form] - if {$idlist eq "*"} { - #* only applies to form ids that exist at the time - set idlist [dict keys $F] - } - set form_ids_active $idlist - } - #new form keys already created if they were needed (done for all records that have -form ) - } - package { - set package_info [dict merge $package_info $at_specs] - } - cmd { - #allow arbitrary - review - set cmd_info [dict merge $cmd_info $at_specs] - } - doc { - set doc_info [dict merge $doc_info $at_specs] - } - argdisplay { - #override the displayed argument table. - #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing - set argdisplay_info [dict merge $argdisplay_info $at_specs] - } - opts { - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "values"} { - error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" - } - dict set F $fid argspace "options" - set tmp_optspec_defaults [dict get $F $fid optspec_defaults] - - foreach {k v} $at_specs { - switch -- $k { - -any - - -anyopts { - set opt_any $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { - #review - only apply to certain types? - tcl::dict::set tmp_optspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_optspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - none - "" - - - any - ansistring - globstring - list { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_optspec_defaults -type $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - #allow overriding of defaults for options that occur later - tcl::dict::set tmp_optspec_defaults $k $v - } - default { - set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" - } - } - } - dict set F $fid optspec_defaults $tmp_optspec_defaults - } ;# end foreach record_form_ids - } - leaders { - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] in [list options values]} { - error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" - } - set tmp_leaderspec_defaults [dict get $F $fid leaderspec_defaults] - - foreach {k v} $at_specs { - switch -- $k { - -min - - -minvalues { - if {$v < 0} { - error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MIN $v - #if {$leader_max == 0} { - # set leader_max -1 - #} - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MAX $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -choiceinfo { - if {[llength $v] %2 != 0} { - error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - #-choicegroups? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_leaderspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set tmp_leaderspec_defaults $k $v - } - default { - set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid leaderspec_defaults $tmp_leaderspec_defaults - - } ;#end foreach record_form_ids - - } - values { - foreach fid $record_form_ids { - dict set F $fid argspace "values" - - set tmp_valspec_defaults [dict get $F $fid valspec_defaults] - - foreach {k v} $at_specs { - switch -- $k { - -form { - } - -min - - -minvalues { - if {$v < 0} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" - } - set val_min $v - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" - } - set val_max $v - } - -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_valspec_defaults $k $v - } - -choiceinfo - -choicegroups { - if {[llength $v] % 2 != 0} { - error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - # -choicegroups ?? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_valspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set tmp_valspec_defaults $k $v - } - default { - set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid valspec_defaults $tmp_valspec_defaults - } - - } - seealso { - #todo! - #like @doc, except displays in footer, multiple - sub-table? - set seealso_info [dict merge $seealso_info $at_specs] - } - keywords { - #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? - set keywords_info [dict merge $keywords_info $at_specs] - } - default { - error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @argdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" - } - } - #record_type directive - continue - } elseif {$firstchar eq "-"} { - set argname $firstword - set argdef_values $record_values - tcl::dict::set argdef_values -ARGTYPE option - - - - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - dict set F $fid argspace "options" - } elseif {[dict get $F $fid argspace] eq "values"} { - error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" - } - set record_type option - dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] - #lappend opt_names $argname - } - - set is_opt 1 - } else { - set argname $firstword - if {$firstchar eq "@"} { - #allow basic @@ escaping for literal argname that begins with @ - set argname [tcl::string::range $argname 1 end] - } - - set argdef_values $record_values - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - set record_type leader - tcl::dict::set argdef_values -ARGTYPE leader - #lappend leader_names $argname - set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] - if {$argname ni $temp_leadernames} { - lappend temp_leadernames $argname - tcl::dict::set F $fid LEADER_NAMES $temp_leadernames - } else { - error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" - } - - if {[dict get $F $fid LEADER_MAX] >= 0} { - dict set F $fid LEADER_MAX [llength $temp_leadernames] - } - } else { - set record_type value - tcl::dict::set argdef_values -ARGTYPE value - set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] - lappend temp_valnames $argname - tcl::dict::set F $fid VAL_NAMES $temp_valnames - #lappend val_names $argname - } - } - - set is_opt 0 - } - - - #assert - we only get here if it is a value or flag specification line. - #assert argdef_values has been set to the value of record_values - - foreach fid $record_form_ids { - if {$is_opt} { - set spec_merged [dict get $F $fid optspec_defaults] - } else { - if {[dict get $F $fid argspace] eq "values"} { - set spec_merged [dict get $F $fid valspec_defaults] - } else { - set spec_merged [dict get $F $fid leaderspec_defaults] - } - } - - # -> argopt argval - foreach {spec specval} $argdef_values { - #literal-key switch - bytecompiled to jumpTable - switch -- $spec { - -form { - - } - -type { - #normalize here so we don't have to test during actual args parsing in main function - switch -- [tcl::string::tolower $specval] { - int - integer { - tcl::dict::set spec_merged -type int - } - bool - boolean { - tcl::dict::set spec_merged -type bool - } - char - character { - tcl::dict::set spec_merged -type char - } - dict - dictionary { - tcl::dict::set spec_merged -type dict - } - "" - none { - if {$is_opt} { - tcl::dict::set spec_merged -type none - 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 - error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" - } - } - any - anything { - tcl::dict::set spec_merged -type any - } - ansi - ansistring { - tcl::dict::set spec_merged -type ansistring - } - any - string - globstring { - tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - } - default { - #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW - tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - } - } - } - -default - -solo - -range - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo - - -minsize - -maxsize - -nocase - -optional - -multiple - - -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - - -regexprepass - -regexprefail - -regexprefailmsg - { - #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines - #review -solo 1 vs -type none ? conflicting values? - tcl::dict::set spec_merged $spec $specval - } - -validationtransform { - #string is dict only 8.7/9+ - if {[llength $specval] % 2} { - error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" - } - dict for {tk tv} $specval { - switch -- $tk { - -function - -type - -minsize - -maxsize - -range { - } - default { - set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? - error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" - } - } - } - - } - default { - if {[string match ref-* $spec]} { - #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) - #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. - if {![tcl::dict::exists $refs $specval]} { - puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" - } else { - set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" - if {$targetswitch eq "-*"} { - set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id - } else { - if {[tcl::dict::exists $refs $specval $targetswitch]} { - tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] - } else { - puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" - } - } - } - } else { - set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - ] - error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" - } - } - } - } ;# end foreach {spec specval} argdef_values - - - if {$is_opt} { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } else { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - tcl::dict::set F $fid ARG_INFO $argname $spec_merged - #review existence of -default overriding -optional - if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { - if {$is_opt} { - lappend opt_required $argname - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - set temp_leader_required [dict get $F $fid LEADER_REQUIRED] - lappend temp_leader_required $argname - dict set F $fid LEADER_REQUIRED $temp_leader_required - #lappend leader_required $argname - } else { - lappend val_required $argname - } - } - } - if {[tcl::dict::exists $spec_merged -default]} { - if {$is_opt} { - tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } else { - tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] - } - } - } - } ;# end foreach fid record_form_ids - - } ;# end foreach rec $records - - - #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { - # variable id_counter - # set DEF_definition_id "autoid_[incr id_counter]" - #} - - - #check ALL forms not just form_ids_active (record_form_ids) - dict for {fid formdata} $F { - # REVIEW - #no values specified - we can allow last leader to be multiple - foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { - error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" - } - } - #confirm any valnames before last don't have -multiple key - foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { - error "bad key -multiple on argument spec for value '$valname' in command form:'$fid'. Only the last value argument specification can be marked -multiple @id:$DEF_definition_id" - } - } - - #todo - document that ambiguities in API are likely if both @leaders and @values used - #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) - - - dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - - - - - #todo - precalculate a set of 'arity' entries for each form - #We want a structure for the arg parser to get easy access and make a fast decision on which form applies - #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? - #1) after ms (1 1) - #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? - #3) after cancel id (2 2) - #4) after cancel script ?script...? (2 -1) - #5) after idle script ?script...? (1 -1) - #6) after info ?id? (1 2) - - #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) - - #in the above case we have no unique total_arity - #we would also want to consider values when selecting - #e.g given the invalid command "after cancel" - # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. - - - - set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands - #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use - #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form - #e.g commandline completion could show list of synopsis entries to select from - - set form_info [dict create] - dict for {fid fdict} $F { - dict set form_info $fid {} - dict for {optk optv} $fdict { - if {[string match -* $optk]} { - dict set form_info $fid $optk $optv - } - } - } - - set argdata_dict [tcl::dict::create\ - id $DEF_definition_id\ - ARG_INFO [dict get $F $firstformid ARG_INFO]\ - ARG_CHECKS [dict get $F $firstformid ARG_CHECKS]\ - LEADER_DEFAULTS [dict get $F $firstformid LEADER_DEFAULTS]\ - LEADER_REQUIRED [dict get $F $firstformid LEADER_REQUIRED]\ - LEADER_NAMES [dict get $F $firstformid LEADER_NAMES]\ - LEADER_MIN [dict get $F $firstformid LEADER_MIN]\ - LEADER_MAX [dict get $F $firstformid LEADER_MAX]\ - leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ - LEADER_CHECKS_DEFAULTS [dict get $F $firstformid LEADER_CHECKS_DEFAULTS]\ - opt_defaults $opt_defaults\ - opt_required $opt_required\ - OPT_NAMES [dict get $F $firstformid OPT_NAMES]\ - opt_any $opt_any\ - opt_solos $opt_solos\ - optspec_defaults [dict get $F $firstformid optspec_defaults]\ - OPT_CHECKS_DEFAULTS [dict get $F $firstformid OPT_CHECKS_DEFAULTS]\ - val_defaults $val_defaults\ - val_required $val_required\ - VAL_NAMES [dict get $F $firstformid VAL_NAMES]\ - val_min $val_min\ - val_max $val_max\ - valspec_defaults [dict get $F $firstformid valspec_defaults]\ - VAL_CHECKS_DEFAULTS [dict get $F $firstformid VAL_CHECKS_DEFAULTS]\ - cmd_info $cmd_info\ - doc_info $doc_info\ - package_info $package_info\ - argdisplay_info $argdisplay_info\ - seealso_info $seealso_info\ - id_info $id_info\ - FORMS $F\ - form_names [dict keys $F]\ - FORM_INFO $form_info\ - ] - - tcl::dict::set argdata_cache $cache_key $argdata_dict - if {$is_dynamic} { - #also cache resolved version - tcl::dict::set argdata_cache $optionspecs $argdata_dict - } - - #tcl::dict::set id_cache_rawdef $DEF_definition_id $args - #puts "xxx:$result" - return $argdata_dict - } - - #return raw definition list as created with 'define' - # - possibly with unresolved dynamic parts - proc raw_def {id} { - variable id_cache_rawdef - set realid [real_id $id] - if {![dict exists $id_cache_rawdef $realid]} { - return "" - } - return [tcl::dict::get $id_cache_rawdef $realid] - } - - - namespace eval argdoc { - variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @argdisplay @seealso @leaders @opts @values leaders opts values} - variable resolved_def_TYPE_CHOICEGROUPS { - directives {@id @package @cmd @ref @doc @argdisplay @seealso} - argumenttypes {leaders opts values} - remaining_defaults {@leaders @opts @values} - } - - lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { - @id -id ::punk::args::resolved_def - @cmd -name punk::args::resolved_def -help\ - "Resolves or retrieves the previously resolved definition and - uses the 'spec' form to build a response in definition format. - - Pulling argument definition data from another function is a form - of tight coupling to the other function that should be done with - care. - - Note that the directives @leaders @opts @values may appear multiple - times in a source definition - applying defaults for arguments that - follow. When retrieving these - there is only a single result for - each that represents the defaults after all have been applied. - When retrieving -types * each of these will be positioned before - the arguments of that type - but this doesn't mean there was a single - leading directive for this argument type in the source definition. - Each argument has already had its complete specification recorded in - its own result. - - When manually specifying -types, the order @leaders then @opts then - @values must be maintained - but if they are placed before their - corresponding arguments, they will not affect the retrieved arguments - as these arguments are already fully spec'd. The defaults from the - source can be removed by adding @leaders, @opts @values to the - -antiglobs list, but again - this won't affect the existing arguments. - Each argument can have members of its spec overridden using the - -override dictionary. - " - @leaders -min 0 -max 0 - @opts - -return -default text -choices {text dict} - -form -default 0 -help\ - "Ordinal index or name of command form" - - #no restriction on number of types/repetitions? - -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} - -antiglobs -default {} -type list -help\ - "Glob patterns for directive or argument/flags to - be suppressed" - -override -type dict -optional 1 -default "" -help\ - "dict of dicts. Key in outer dict is the name of a - directive or an argument. Inner dict is a map of - overrides/additions (- ...) for that line. - " - @values -min 1 -max -1 - id -type string -help\ - "identifer for a punk::args definition - This will usually be a fully-qualifed - path for a command name" - pattern -type string -optional 1 -default * -multiple 1 -help\ - "glob-style patterns for retrieving value or switch - definitions. - - If -type is * and pattern is * the entire definition including - directive lines will be returned in line form. - (directives are lines beginning with - @ e.g @id, @cmd etc) - - if -type is leaders,opts or values matches from that type - will be returned. - - if -type is another directive such as @id, @doc etc the - patterns are ignored. - - " - }]] - } - - - proc resolved_def {args} { - #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. - set opts [dict create\ - -return text\ - -types {}\ - -form 0\ - -antiglobs {}\ - -override {}\ - ] - if {[llength $args] < 1} { - #must have at least id - punk::args::parse $args withid ::punk::args::resolved_def - return - } - set patterns [list] - - #a definition id must not begin with "-" ??? review - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {$a in {-type -types}} { - incr i - dict set opts -types [lindex $args $i] - } elseif {[string match -* $a]} { - incr i - dict set opts $a [lindex $args $i] - } else { - set id [lindex $args $i] - set patterns [lrange $args $i+1 end] - break - } - if {$i == [llength $args]-1} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - if {![llength $patterns]} { - set patterns [list *] - } - dict for {k v} $opts { - switch -- $k { - -return - -form - -types - -antiglobs - -override {} - default { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - } - set typelist [dict get $opts -types] - if {[llength $typelist] == 0} { - set typelist {*} - } - foreach type $typelist { - if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - - - variable id_cache_rawdef - set realid [real_id $id] - if {$realid eq ""} { - return - } - - set deflist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] - - set opt_form [dict get $opts -form] - if {[string is integer -strict $opt_form]} { - set formname [lindex [dict get $specdict form_names] $opt_form] - } else { - set formname $opt_form - } - set opt_override [dict get $opts -override] - set opt_return [dict get $opts -return] - - #set arg_info [dict get $specdict ARG_INFO] - set arg_info [dict get $specdict FORMS $formname ARG_INFO] - set argtypes [dict create leaders leader opts option values value] - - set opt_antiglobs [dict get $opts -antiglobs] - set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] - set suppressed_directives [list] - set suppressed_args [list] - foreach ag $opt_antiglobs { - foreach d $directives { - if {[string match $ag $d]} { - lappend suppressed_directives $d - } - } - foreach argname [dict keys $arg_info] { - if {[string match $ag $argname]} { - lappend suppressed_args $argname - } - } - } - set suppressed_directives [lsort -unique $suppressed_directives] - set suppressed_args [lsort -unique $suppressed_args] - - set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] - - set globbed [list] - foreach pat $patterns { - set matches [dict keys $arg_info $pat] - lappend globbed {*}$matches - } - set globbed [lsort -unique $globbed] - set included_args [punk::args::system::punklib_ldiff $globbed $suppressed_args] - - set result "" - set resultdict [dict create] - foreach type $typelist { - switch -exact -- $type { - * { - if {"@id" in $included_directives} { - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - foreach directive {@package @cmd @doc @seealso @argdisplay} { - set dshort [string range $directive 1 end] - if {"$directive" in $included_directives} { - if {[dict exists $opt_override $directive]} { - append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict ${dshort}_info]" - dict set resultdict $directive [dict get $specdict ${dshort}_info] - } - } - } - #output ordered by leader, option, value - foreach pseudodirective {leaders opts values} tp {leader option value} { - set directive "@$pseudodirective" - switch -- $directive { - @leaders {set defaults_key leaderspec_defaults} - @opts {set defaults_key optspec_defaults} - @values {set defaults_key valspec_defaults} - } - - if {"$directive" in $included_directives} { - if {[dict exists $opt_override "$directive"]} { - append result \n "$directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict $defaults_key]" - dict set resultdict $directive [dict get $specdict $defaults_key] - } - } - - if {$pseudodirective in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq $tp} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "$m $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - - } - @id { - if {"@id" in $included_directives} { - #only a single id record can exist - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - } - @package - @cmd - @doc - @seealso - @argdisplay { - if {"$type" in $included_directives} { - set tp [string range $type 1 end] ;# @package -> package - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict ${tp}_info]" - dict set resultdict $type [dict get $specdict ${tp}_info] - } - } - } - @leaders - @opts - @values { - #these are the active defaults for further arguments - if {"$type" in $included_directives} { - switch -- $type { - @leaders {set defaults_key leaderspec_defaults} - @opts {set defaults_key optspec_defaults} - @values {set defaults_key valspec_defaults} - } - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict leaderspec_defaults]" - dict set resultdict $type [dict get $specdict leaderspec_defaults] - } - } - } - leaders - opts - values { - #pseudo-directives - if {$type in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "$m $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - default { - } - } - if {$opt_return eq "text"} { - return $result - } else { - return $resultdict - } - } - } - - proc resolved_def_values {id {patternlist *}} { - variable id_cache_rawdef - set realid [real_id $id] - if {$realid ne ""} { - set speclist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [resolve {*}$speclist] - set arg_info [dict get $specdict ARG_INFO] - set valnames [dict get $specdict VAL_NAMES] - set result "" - if {$patternlist eq "*"} { - foreach v $valnames { - set def [dict get $arg_info $v] - set def [dict remove $def -ARGTYPE] - append result \n "$v $def" - } - return $result - } else { - foreach pat $patternlist { - set matches [dict keys $arg_info $pat] - set matches [lsearch -all -inline -glob $valnames $pat] - foreach m $matches { - set def [dict get $arg_info $m] - set def [dict remove $def -ARGTYPE] - append result \n "$m $def" - } - } - return $result - } - } - } - #proc resolved_def_leaders ?? - #proc resolved_def_opts ?? - - proc get_spec {id} { - set rdef [raw_def $id] - if {$rdef eq ""} {return} - return [resolve {*}$rdef] - #if {[id_exists $id]} { - # return [resolve {*}[raw_def $id]] - #} - } - proc is_dynamic {id} { - variable id_cache_rawdef - variable rawdef_cache - set deflist [raw_def $id] - if {[dict exists $rawdef_cache $deflist -dynamic]} { - return [dict get $rawdef_cache $deflist -dynamic] - } - return [rawdef_is_dynamic $deflist] - #@dynamic only has meaning as 1st element of a def in the deflist - } - - #@id must be within first 4 lines of a block - or assign auto - #review - @dynamic block where -id not explicitly set? - disallow? - proc rawdef_id {rawdef} { - set id "" - foreach d $rawdef { - foreach ln [lrange [split $d \n] 0 4] { - if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { - if {$firstword eq "@id"} { - if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { - set id [dict get $rest -id] - break - } - } - } - } - if {$id ne ""} { - break - } - } - if {$id eq "" || [string tolower $id] eq "auto"} { - variable id_counter - set id "autoid_[incr id_counter]" - } - #puts "==>id: $id" - return $id - } - #test the rawdef for @dynamic directive - proc rawdef_is_dynamic {rawdef} { - #temporary - old way - set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] - if {$flagged_dynamic} { - return true - } - foreach d $rawdef { - if {[regexp {\s*(\S+)} $d _match firstword]} { - if {$firstword eq "@dynamic"} { - return true - } - } - } - return false - } - - variable aliases - set aliases [dict create] - - lappend PUNKARGS [list { - @id -id ::punk::args::get_ids - @cmd -name punk::args::get_ids -help\ - "return list of ids for argument definitions" - @values -min 0 -max 1 - match -default * -help\ - "exact id or glob pattern for ids" - }] - proc get_ids {{match *}} { - variable id_cache_rawdef - variable aliases - return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] - } - - #we don't automatically test for (autodef)$id - only direct ids and aliases - proc id_exists {id} { - variable aliases - if {[tcl::dict::exists $aliases $id]} { - return 1 - } - variable id_cache_rawdef - tcl::dict::exists $id_cache_rawdef $id - } - proc set_alias {alias id} { - variable aliases - dict set aliases $alias $id - } - proc unset_alias {alias} { - variable aliases - dict unset aliases $alias - } - proc get_alias {alias} { - variable aliases - if {[dict exists $aliases $alias]} { - return [tcl::dict::get $aliases $alias] - } - } - - proc real_id {id} { - variable id_cache_rawdef - variable aliases - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } else { - set check_updates [list [namespace qualifiers $id]] - if {![llength [update_definitions $check_updates]]} { - #nothing new loaded - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } else { - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } - } - } - - proc status {} { - upvar ::punk::args::register::NAMESPACES registered - upvar ::punk::args::register::loaded_packages loaded_packages - upvar ::punk::args::register::loaded_info loaded_info - upvar ::punk::args::register::scanned_packages scanned_packages - upvar ::punk::args::register::scanned_info scanned_info - set result "" - # [format %-${w0}s $idtail] - set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] - append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n - set width_c2 [string length "Scanned_ids"] - set width_c3 [string length "Scantime_us"] - set width_c4 [string length "Loaded_defs"] - set width_c5 [string length "Loadtime_us"] - set count_unloaded 0 - set count_loaded 0 - foreach ns $registered { - if {$ns in $scanned_packages} { - set ids [dict get $scanned_info $ns idcount] - set scan_us [dict get $scanned_info $ns time] - } else { - set ids "" - set scan_us "" - } - if {$ns in $loaded_packages} { - incr count_loaded - set ldefs [dict get $loaded_info $ns defcount] - set load_us [dict get $loaded_info $ns time] - } else { - incr count_unloaded - set ldefs "" - set load_us "" - } - append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n - } - append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" - return $result - } - - #scanned_packages (list) - #namespace_docpackages (dict) - proc update_definitions {{nslist *}} { - if {[set gposn [lsearch $nslist {}]] >= 0} { - lset nslist $gposn :: - } - upvar ::punk::args::register::NAMESPACES registered ;#list - upvar ::punk::args::register::loaded_packages loaded_packages ;#list - upvar ::punk::args::register::loaded_info loaded_info ;#dict - upvar ::punk::args::register::scanned_packages scanned_packages ;#list - upvar ::punk::args::register::scanned_info scanned_info ;#dict - upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict - - - #puts stderr "-->update_definitions '$nslist'" - #needs to run quickly - especially when no package namespaces to be scanned for argdefs - #e.g - gets called for each subcommand of an ensemble (could be many) - # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. - #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. - # -- --- --- --- --- --- - # common-case fast-path - - if {[llength $loaded_packages] == [llength $registered]} { - #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. - #assert - if all are registered - then all have been scanned ( - return {} - } - # -- --- --- --- --- --- - - set unscanned [punklib_ldiff $registered $scanned_packages] - if {[llength $unscanned]} { - foreach pkgns $unscanned { - set idcount 0 - set ts_start [clock microseconds] - if {[info exists ${pkgns}::PUNKARGS]} { - set seen_documentedns [list] ;#seen per pkgns - foreach definitionlist [set ${pkgns}::PUNKARGS] { - #namespace eval $evalns [list punk::args::define {*}$definitionlist] - set id [rawdef_id $definitionlist] - if {[string match autoid_* $id]} { - puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" - puts stderr "definition:\n" - foreach d $definitionlist { - set out "" - foreach ln [split $d \n] { - append out " " $ln \n - } - puts $out - } - continue - } - #todo - detect duplicate ids (last will silently win.. should be reported somewhere) - incr idcount - set documentedns [namespace qualifiers $id] - if {$documentedns eq ""} {set documentedns ::} - if {$documentedns ni $seen_documentedns} { - #don't add own ns as a key in namespace_docpackages - if {$documentedns ne $pkgns} { - dict lappend namespace_docpackages $documentedns $pkgns - } - lappend seen_documentedns $documentedns - } - } - } - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - dict set scanned_info $pkgns [dict create time $diff idcount $idcount] - #we count it as scanned even if PUNKARGS didn't exist - #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) - lappend scanned_packages $pkgns - } - } - - - - if {"*" in $nslist} { - set needed [punklib_ldiff $registered $loaded_packages] - } else { - set needed [list] - foreach pkgns $nslist { - if {$pkgns in $registered && $pkgns ni $loaded_packages} { - lappend needed $pkgns - } - #argdoc sub namespace is a standard place to put defs that match the namespace below - #(generally the PUNKARGS in a namespace should apply to own ns) - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { - lappend needed $docns - } - } - if {[dict exists $namespace_docpackages $pkgns]} { - #this namespace has other argdef sources - foreach docns [dict get $namespace_docpackages $pkgns] { - if {$docns ni $loaded_packages} { - lappend needed $docns - } - } - } - } - } - - - - set newloaded [list] - foreach pkgns $needed { - #puts stderr "update_definitions Loading: $pkgns" - set ts_start [clock microseconds] - set def_count 0 - if {![catch { - if {[info exists ${pkgns}::PUNKARGS]} { - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - namespace eval ${pkgns}::argdoc { - set epath [namespace path] - set pkgns [namespace parent] - if {$pkgns ni $epath} { - namespace path [list {*}$epath $pkgns] ;#add to tail - } - - } - set evalns $docns - } else { - set evalns $pkgns - } - foreach definitionlist [set ${pkgns}::PUNKARGS] { - namespace eval $evalns [list punk::args::define {*}$definitionlist] - incr def_count - } - } - - #process list of 2-element lists - if {[info exists ${pkgns}::PUNKARGS_aliases]} { - foreach adef [set ${pkgns}::PUNKARGS_aliases] { - punk::args::set_alias {*}$adef - } - } - } errMsg]} { - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - lappend loaded_packages $pkgns - lappend newloaded $pkgns - dict set loaded_info $pkgns [dict create time $diff defcount $def_count] - } else { - puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" - } - } - return $newloaded - } - - #for use within get_dict only - #This mechanism gets less-than-useful results for oo methods - #e.g {$obj} - proc Get_caller {} { - #set call_level -3 ;#for get_dict call - set call_level -4 - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - #puts "-->$cmdinfo" - #puts "-->[tcl::info::frame -3]" - while {[string last \n $cmdinfo] >= 1} { - #looks like a script - haven't gone up far enough? - #(e.g patternpunk oo system: >punk . poses -invalidoption) - incr call_level -1 - if {[catch { - set nextup [tcl::info::frame $call_level] - } ]} { - break - } - set cmdinfo [tcl::dict::get $nextup cmd] - set caller [regexp -inline {\S+} $cmdinfo] - if {[interp alias {} $caller] ne ""} { - #puts "found alias for caller $caller to [interp alias {} $caller]" - #see if we can go further - incr call_level -1 - if {[catch { - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - } errM ]} { - puts "err: $errM" - break - } - } - } - set caller [regexp -inline {\S+} $cmdinfo] - if {$caller eq "namespace"} { - # review - message? - set cmdinfo "punk::args::get_dict called from namespace" - } - return $cmdinfo - } - - - # -------------------------------------- - #test of Get_caller - lappend PUNKARGS [list { - @id -id ::punk::args::test1 - @values -min 0 -max 0 - }] - proc test_get_dict {args} { - punk::args::get_dict {*}[punk::args::raw_def ::punk::args::test1] $args - } - proc test_get_by_id {args} { - punk::args::get_by_id ::punk::args::test1 $args - } - #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. - proc test_callers {args} { - if {![llength $args]} { - puts "these test functions accept no arguments" - puts "Call with arg(s) to compare error output" - } - - if {[catch {test_get_dict {*}$args} errM]} { - puts $errM - } - puts "------------" - if {[catch {test_get_by_id {*}$args} errM]} { - puts $errM - } - return done - } - # -------------------------------------- - - set map "" - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::arg_error - @cmd -name punk::args::arg_error -help\ - "Generates a table (by default) of usage information for a command. - A trie system is used to create highlighted prefixes for command - switches and for subcommands or argument/switch values that accept - a defined set of choices. These prefixes match the mechanism used - to validate arguments (based on tcl::prefix::match). - - This function is called during the argument parsing process - (if the definition is not only being used for documentation) - It is also called by punk::args::usage which is in turn - called by the punk::ns introspection facilities which creates - on the fly definitions for some commands such as ensembles and - oo objects where a manually defined one isn't present. - " - @leaders -min 2 -max 2 - msg -type string -help\ - "Error message to display immediately prior to usage table. - May be empty string to just display usage. - " - spec_dict -type dict -help\ - "Dictionary of argument specifications. - This is the internal format parsed from - the textual definition. It contains the data - organised/optimised to allow the final arg - parser/validator to make decisions. - " - @opts - -badarg -type string -help\ - "name of an argument to highlight" - -aserror -type boolean -help\ - "If true, the usage table is raised as an error message, - otherwise it is returned as a value." - -return -choices {string table tableobject} -choicelabels { - string "no table layout" - tableobject "table object cmd" - table "full table laout" - } - -scheme -default error -choices {nocolour info error} - }] ] - - #basic recursion blocker - variable arg_error_isrunning 0 - proc arg_error {msg spec_dict args} { - #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. - #accept an option here so that we can still use full output for usage requests. - #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args - #Development/experimentation may be done with full table-based error reporting - but for production release it - #may be desirable to reduce overhead on catches. - #consider per-namespace or namespace-tree configurability. - #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due - #to resource availability etc - so the slower error generation time may not always be a problem. - #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling - #code which has no use for the enhanced error info. - #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. - #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system - #todo - #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error - #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) - - #todo - document unnamed leaders and unnamed values where -min and/or -max specified - #e.g punk::args::get_dict {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} {} - #only |?-x?|string|... is shown in the output table. - #should be something like: - # |arg | - # |?-x? | - # |arg | - # |?arg...?| - # Where/how to specify counts? - #also.. - # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? - # - - - if {[catch {package require punk::ansi}]} { - proc punk::args::a {args} {} - proc punk::args::a+ {args} {} - } else { - namespace eval ::punk::args { - namespace import ::punk::ansi::a ::punk::ansi::a+ - } - } - #limit colours to standard 16 so that themes can apply to help output - variable arg_error_isrunning - if {$arg_error_isrunning} { - error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" - } - - if {[llength $args] %2 != 0} { - error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" - } - - set arg_error_isrunning 1 - - set badarg "" - set returntype table ;#table as string - set as_error 1 ;#usual case is to raise an error - set scheme error - dict for {k v} $args { - set fullk [tcl::prefix::match -error "" {-badarg -aserror -return -scheme} $k] - switch -- $fullk { - -badarg { - set badarg $v - } - -aserror { - if {![string is boolean -strict $v]} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" - } - set as_error $v - } - -scheme { - set scheme $v - } - -return { - if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" - } - set returntype $v - } - default { - set arg_error_isrunning 0 - error "arg_error invalid option $k. Known_options: -badarg -return -aserror" - } - } - } - #todo - scheme - use config and iterm toml definitions etc - switch -- $scheme { - "" - -nocolor - -nocolour { - set scheme nocolour - } - info - error {} - default { - set scheme na - } - } - #hack some basics for now. - #for coloured schemes - use bold as well as brightcolour in case colour off. - array set CLR {} - set CLR(errormsg) [a+ brightred] - set CLR(title) "" - set CLR(check) [a+ brightgreen] - set CLR(solo) [a+ brightcyan] - set CLR(choiceprefix) [a+ underline] - set CLR(badarg) [a+ brightred] - set CLR(linebase_header) [a+ white] - set CLR(cmdname) [a+ brightwhite] - set CLR(groupname) [a+ bold] - set CLR(ansiborder) [a+ bold] - set CLR(ansibase_header) [a+ bold] - set CLR(ansibase_body) [a+ white] - - switch -- $scheme { - nocolour { - set CLR(errormsg) [a+ bold] - set CLR(title) [a+ bold] - set CLR(check) "" - set CLR(solo) "" - set CLR(badarg) [a+ reverse] ;#? experiment - set CLR(cmdname) [a+ bold] - set CLR(linebase_header) "" - set CLR(linebase) "" - set CLR(ansibase_body) "" - } - info { - set CLR(errormsg) [a+ brightred bold] - set CLR(title) [a+ brightyellow bold] - set CLR(check) [a+ brightgreen bold] - set CLR(choiceprefix) [a+ brightgreen bold] - set CLR(groupname) [a+ cyan bold] - set CLR(ansiborder) [a+ brightcyan bold] - set CLR(ansibase_header) [a+ cyan] - set CLR(ansibase_body) [a+ white] - } - error { - set CLR(errormsg) [a+ brightred bold] - set CLR(title) [a+ brightcyan bold] - set CLR(check) [a+ brightgreen bold] - set CLR(choiceprefix) [a+ brightgreen bold] - set CLR(groupname) [a+ cyan bold] - set CLR(ansiborder) [a+ brightyellow bold] - set CLR(ansibase_header) [a+ yellow] - set CLR(ansibase_body) [a+ white] - } - na { - } - } - - - #set RST [a] - set RST "\x1b\[m" - set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. - - #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error - #e.g list_as_table - - # use basic colours here to support terminals without extended colours - #todo - add checks column (e.g -minsize -maxsize) - set errmsg $msg - if {![catch {package require textblock}]} { - set has_textblock 1 - } else { - set has_textblock 0 - #couldn't load textblock package - #just return the original errmsg without formatting - } - set use_table 0 - if {$has_textblock && $returntype in {table tableobject}} { - set use_table 1 - } - set errlines [list] ;#for non-textblock output - if {[catch { - if {$use_table} { - append errmsg \n - } else { - if {($returntype in {table tableobject}) && !$has_textblock} { - append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n - } else { - append errmsg \n - } - } - set cmdname [Dict_getdef $spec_dict cmd_info -name ""] - set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] - - set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] - set docurl [Dict_getdef $spec_dict doc_info -url ""] - - set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] - set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] - if {"$argdisplay_header$argdisplay_body" eq ""} { - set is_custom_argdisplay 0 - } else { - set is_custom_argdisplay 1 - } - - - set blank_header_col [list] - if {$cmdname ne ""} { - lappend blank_header_col "" - set cmdname_display $CLR(cmdname)$cmdname$RST - } else { - set cmdname_display "" - } - if {$cmdhelp ne ""} { - lappend blank_header_col "" - #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] - set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] - } else { - set cmdhelp_display "" - } - if {$docurl ne ""} { - lappend blank_header_col "" - set docurl_display [a+ white]$docurl$RST - } else { - set docurl_display "" - } - #synopsis - set synopsis "" - set form_info [dict get $spec_dict FORM_INFO] - dict for {fid finfo} $form_info { - set syn [Dict_getdef $finfo -synopsis ""] - if {$syn ne ""} { - append synopsis $syn \n - } - } - if {$synopsis ne ""} { - set synopsis [string range $synopsis 0 end-1] - lappend blank_header_col "" - } - - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - if {$use_table} { - set t [textblock::class::table new "$CLR(title)Usage$RST"] - $t add_column -headers $blank_header_col -minwidth 3 - $t add_column -headers $blank_header_col - - if {!$is_custom_argdisplay} { - lappend blank_header_col "" - #spanned columns in default argdisplay area - $t add_column -headers $blank_header_col ;#Default - $t add_column -headers $blank_header_col ;#Multi - $t add_column -headers $blank_header_col ;#Help - set arg_colspans {1 4 0 0 0} - } else { - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - set arg_colspans {1 1} - } - } - set h 0 - if {$cmdname ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] - } else { - lappend errlines "COMMAND: $cmdname_display" - } - incr h - } - if {$cmdhelp ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] - } else { - lappend errlines "Description: $cmdhelp_display" - } - incr h - } - if {$docurl ne ""} { - if {![catch {package require punk::ansi}]} { - set docurl [punk::ansi::hyperlink $docurl] - } - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] - } else { - lappend errlines "$docname $docurl_display" - } - incr h - } - if {$synopsis ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Synopsis: $synopsis] - } else { - #todo - lappend errlines "Synopsis:\n$synopsis" - } - incr h - } - - - if {$use_table} { - if {$is_custom_argdisplay} { - if {$argdisplay_header ne ""} { - $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] - } - } else { - $t configure_header $h -values {Arg Type Default Multi Help} - } - } else { - lappend errlines " --ARGUMENTS-- " - } - - if {$is_custom_argdisplay} { - if {$use_table} { - #using overall container table - #header already added - #TODO - review textblock::table features - #we can't currently span columns within the table body. - #This feature could allow hidden data columns (and sort on hidden col?) - #potentially require coordination with header colspans? - $t add_row [list "" $argdisplay_body] - } else { - if {$argdisplay_header ne ""} { - lappend errlines $argdisplay_header - } - lappend errlines {*}$argdisplay_body - } - } else { - - #set A_DEFAULT [a+ brightwhite Brightgreen] - set A_DEFAULT "" - set A_BADARG $CLR(badarg) - set greencheck $CLR(check)\u2713$RST ;#green tick - set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply - if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { - #A_PREFIX can resolve to empty string if colour off - #we then want to display underline instead - set A_PREFIX [a+ underline] - set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space - } else { - set A_PREFIXEND $RST - } - - set opt_names [list] - set opt_names_display [list] - if {[llength [dict get $spec_dict OPT_NAMES]]} { - if {![catch {package require punk::trie}]} { - set trie [punk::trie::trieclass new {*}[dict get $spec_dict OPT_NAMES]] - set idents [dict get [$trie shortest_idents ""] scanned] - #todo - check opt_prefixdeny - - $trie destroy - foreach c [dict get $spec_dict OPT_NAMES] { - set id [dict get $idents $c] - #REVIEW - if {$id eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $id] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail - #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] - lappend opt_names $c - } - } else { - set opt_names [dict get $spec_dict OPT_NAMES] - set opt_names_display $opt_names - } - } - set leading_val_names [dict get $spec_dict LEADER_NAMES] - set trailing_val_names [dict get $spec_dict VAL_NAMES] - - #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { - # if {![string match -* $argname]} { - # lappend leading_val_names [lpop trailing_val_names 0] - # } else { - # break - # } - #} - #if {![llength $leading_val_names] && ![llength $opt_names]} { - # #all vals were actually trailing - no opts - # set trailing_val_names $leading_val_names - # set leading_val_names {} - #} - set leading_val_names_display $leading_val_names - set trailing_val_names_display $trailing_val_names - - #display options first then values - foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { - lassign $argumentset argnames_display argnames - - foreach argshow $argnames_display arg $argnames { - set arginfo [dict get $spec_dict ARG_INFO $arg] - if {[dict exists $arginfo -default]} { - set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" - } else { - set default "" - } - set help [Dict_getdef $arginfo -help ""] - set allchoices_originalcase [list] - set choices [Dict_getdef $arginfo -choices {}] - set choicegroups [Dict_getdef $arginfo -choicegroups {}] - set choicemultiple [dict get $arginfo -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] - set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] - if {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - set is_multiple 1 - } else { - set multiple "" - set is_multiple 0 - } - if {[dict exists $choicegroups ""]} { - dict lappend choicegroups "" {*}$choices - } else { - set choicegroups [dict merge [dict create "" $choices] $choicegroups] - } - dict for {groupname clist} $choicegroups { - lappend allchoices_originalcase {*}$clist - } - set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] - - if {$has_choices} { - if {$help ne ""} {append help \n} - if {[dict get $arginfo -nocase]} { - set casemsg " (case insensitive)" - set allchoices_test [string tolower $allchoices_originalcase] - } else { - set casemsg " (case sensitive)" - set allchoices_test $allchoices_originalcase - } - if {[dict get $arginfo -choiceprefix]} { - set prefixmsg " (choice prefix allowed)" - } else { - set prefixmsg "" - } - set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] - set formattedchoices [dict create] ;#use dict rather than array to preserve order - append help " Choices$prefixmsg$casemsg" - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - if {$choicemultiple_max == -1} { - append help \n " The value can be a list of $choicemultiple_min or more of these choices" - } else { - if {$choicemultiple_min eq $choicemultiple_max} { - append help \n " The value must be a list of $choicemultiple_min of these choices" - } else { - append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" - } - } - } - if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set cdisplay $c - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - dict lappend formattedchoices $groupname $cdisplay - } - } - } else { - set formattedchoices $choicegroups - #set formattedchoices [dict get $arginfo -choices] - } - } else { - if {[catch { - set trie [punk::trie::trieclass new {*}$allchoices_test] - set idents [dict get [$trie shortest_idents ""] scanned] - if {[dict get $arginfo -nocase]} { - #idents were calculated on lcase - remap keys in idents to original casing - set actual_idents $idents - foreach ch $allchoices_originalcase { - if {![dict exists $idents $ch]} { - #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting - #The actual testing is done in get_dict - dict set actual_idents $ch [dict get $idents [string tolower $ch]] - } - } - set idents $actual_idents - #puts "-----" - #puts "idents $idents" - } - - $trie destroy - dict for {groupname clist} $choicegroups { - foreach c $clist { - if {$c in $choiceprefixdenylist} { - set shortestid $c - } else { - set shortestid [dict get $idents $c] - } - if {$shortestid eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $shortestid] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]" - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - dict lappend formattedchoices $groupname $cdisplay - } - } - } errM]} { - #this failure can happen if -nocase is true and there are ambiguous entries - #e.g -nocase 1 -choices {x X} - puts stderr "prefix marking failed\n$errM" - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set cdisplay $c - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - dict lappend formattedchoices $groupname $cdisplay - } - } - } else { - set formattedchoices $choicegroups - } - - } - } - set choicetable_objects [list] - set choicetable_footers [dict create] - dict for {groupname formatted} $formattedchoices { - set numcols $choicecolumns ;#todo - dynamic? - if {[llength $formatted] < $numcols} { - #don't show blank cells if single line of results - set numcols [llength $formatted] - } - if {$numcols > 0} { - if {$use_table} { - #risk of recursing - #TODO -title directly in list_as_table - set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] - lappend choicetable_objects $choicetableobj - $choicetableobj configure -title $CLR(groupname)$groupname - #append help \n[textblock::join -- " " [$choicetableobj print]] - } else { - if {$groupname ne ""} { - append help \n \n "$CLR(groupname)Group: $groupname$RST" - } else { - append help \n - } - append help \n [join $formatted \n] - } - } else { - #we were given an empty set of choices. - #probably an error in the definition - but could happen if dynamically generated. - #(e.g ensemble where unknown mechanism is used for subcommands?) - #better to just display that there were none rather than totally break the usage output. - if {$usetable} { - #these will be displayed after all table entries - if {$groupname eq ""} { - dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" - } else { - dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" - } - } else { - if {$groupname eq ""} { - append help \n " " $CLR(errormsg)(no choices defined)$RST - } else { - append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST - } - } - } - } - set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width - foreach obj $choicetable_objects { - dict lappend twidths_by_colcount [$obj column_count] [$obj width] - } - foreach obj $choicetable_objects { - set cols [$obj column_count] - set widths [dict get $twidths_by_colcount $cols] - set max [tcl::mathfunc::max {*}$widths] - $obj configure -minwidth $max ;#expand smaller ones - set i 0 - while {$i < $cols} { - #keep text aligned left on expanded tables - $obj configure_column $i -blockalign left - incr i - } - - append help \n[textblock::join -- " " [$obj print]] - #set ansititle [dict get [$obj configure -title] value] - $obj destroy - } - if {[dict size $choicetable_footers]} { - foreach groupname [dict keys $formattedchoices] { - if {[dict exists $choicetable_footers $groupname]} { - append help \n [dict get $choicetable_footers $groupname] - } - } - } - - #review. use -type to restrict additional choices - may be different to values in the -choices - if {![dict get $arginfo -choicerestricted]} { - #when -choicemultiple - the -type refers to each selection - if {[dict get $arginfo -type] eq "string"} { - append help "\n (values not in defined choices are allowed)" - } else { - append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" - } - } - } - if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { - if {$is_multiple} { - set argshow "?${argshow}...?" - } else { - set argshow "?${argshow}?" - } - } else { - if {$is_multiple} { - set argshow "${argshow}..." - } - } - set typeshow [dict get $arginfo -type] - if {$typeshow eq "none"} { - set typeshow "$typeshow $soloflag" - } - if {[dict exists $arginfo -minsize]} { - append typeshow \n "-minsize [dict get $arginfo -minsize]" - } - if {[dict exists $arginfo -maxsize]} { - append typeshow \n "-maxsize [dict get $arginfo -maxsize]" - } - if {[dict exists $arginfo -range]} { - append typeshow \n "-range [dict get $arginfo -range]" - } - - if {$use_table} { - $t add_row [list $argshow $typeshow $default $multiple $help] - if {$arg eq $badarg} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG - } - } else { - #review - formatting will be all over the shop due to newlines in typesshow, help - set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" - foreach ln [split $help \n] { - append arghelp " $ln" \n - } - lappend errlines $arghelp - } - } - } - } ;#end is_custom_argdisplay - - if {$use_table} { - $t configure -show_hseps 0\ - -show_header 1\ - -ansibase_body $CLR(ansibase_body)\ - -ansibase_header $CLR(ansibase_header)\ - -ansiborder_header $CLR(ansiborder)\ - -ansiborder_body $CLR(ansiborder) - - $t configure -maxwidth 80 ;#review - if {$returntype ne "tableobject"} { - append errmsg [$t print] - #returntype of table means just the text of the table - $t destroy - } - } else { - append errmsg [join $errlines \n] - } - } errM]} { - catch {$t destroy} - append errmsg \n - append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n - append errmsg "$errM" \n - append errmsg "$::errorInfo" - - } - set arg_error_isrunning 0 - if {$use_table} { - #assert returntype is one of table, tableobject - set result $errmsg ;#default if for some reason table couldn't be used - if {$returntype eq "tableobject"} { - if {[info object isa object $t]} { - set result $t - } - } - } else { - set result $errmsg - } - if {$as_error} { - #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. - #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) - uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] - } else { - return $result - } - } - - - lappend PUNKARGS [list { - @dynamic - @id -id ::punk::args::usage - @cmd -name punk::args::usage -help\ - "Return usage information for a command identified by an id. - - This will only work for commands where a punk::args definition exists - for the command and an id has been defined for it. The id for custom - help for a command should match the fully qualified name of the command. - - Many commands (such as ensembles and oo objects) may have argument - documentation generated dynamically and may not yet have an id. - IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. - - Generally punk::ns::arginfo (aliased as i in the punk shell) should - be used in preference - as it will search for a documentation - mechanism and call punk::args::usage as necessary. - " - -return -default table -choices {string table tableobject} - } {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}} { - - @values -min 0 -max 1 - id -help\ - "Exact id. - Will usually match the command name" - }] - proc usage {args} { - lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received - set id [dict get $values id] - set real_id [real_id $id] - if {$real_id eq ""} { - error "punk::args::usage - no such id: $id" - } - arg_error "" [punk::args::get_spec $real_id] -scheme punk_info {*}$opts -aserror 0 - } - - lappend PUNKARGS [list { - @id -id ::punk::args::get_by_id - @cmd -name punk::args::get_by_id - @values -min 1 - id - arglist -type list -help\ - "list containing arguments to be parsed as per the - argument specification identified by the supplied id." - }] - - - #deprecate? - proc get_by_id {id arglist} { - set definitionlist [punk::args::raw_def $id] - if {[llength $definitionlist] == 0} { - error "punk::args::get_by_id - no such id: $id" - } - #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] - tailcall ::punk::args::get_dict {*}$definitionlist $arglist - } - - #consider - - #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) - #parse ?-flag val?... -- $arglist withid $id - #parse ?-flag val?... -- $arglist withdef $def ?$def?... - - #an experiment.. ideally we'd like arglist at the end? - #parse_withid ?-flag val?.. $id $arglist - #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? - #no possible equivalent for parse_withdef ??? - - lappend PUNKARGS [list { - @id -id ::punk::args::parse - @cmd -name punk::args::parse -help\ - "parse and validate command arguments based on a definition. - - In the 'withid' form the definition is a pre-existing record that has been - created with ::punk::args::define, or indirectly by adding a definition to - the PUNKARGS variable in a namespace which is then registered in - punk::args::register::NAMESPACES, or by a previous call to punk::parse - using 'withdef' and a definition block containing an @id -id directive. - - In the 'withdef' form - the definition is created on the first call and - cached thereafter, if the id didn't already exist. - - form1: parse $arglist ?-flag val?... withid $id - form2: parse $arglist ?-flag val?... withdef $def ?$def? - see punk::args::define - - Returns a dict of information regarding the parsed arguments - example of basic usage for single option only: - punk::args::define { - @id -id ::myns::myfunc - @cmd -name myns::myfunc - @leaders -min 0 -max 0 - @opts - -configfile -type existingfile - #type none makes it a solo flag - -verbose -type none - @values -min 0 -max 0 - } - proc myfunc {args} { - set argd [punk::args::parse $args withid ::myns::myfunc] - lassign [dict values $argd] leaders opts values received solos - if {[dict exists $received] -configfile} { - puts \"have option for existing file [dict get $opts -configfile]\" - } - } - The leaders, opts, values keys in the parse result dict are proper dicts. - The received key is dict-like but can have repeated keys for arguments than can - accept multiples. The value for each received element is the ordinal position. - The solos key refers to a list of solo flags received (those specified with - -type none). This is generally only useful to assist in passing arguments on - to another procedure which also requires solos, because the opts dict contains - solo flags with a 1 value or a list of 1's if it was a solo with -multiple true - specified. - " - @form -form {withid withdef} - @leaders -min 1 -max 1 - arglist -type list -optional 0 -help\ - "Arguments to parse - supplied as a single list" - - @opts - -form -type list -default * -help\ - "Restrict parsing to the set of forms listed. - Forms are the orthogonal sets of arguments a - command can take - usually described in 'synopsis' - entries." - #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance - #todo - configurable per interp/namespace - -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} - - @values -min 2 - - @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" - withid -type literal -help\ - "The literal value 'withid'" - id -type string -help\ - "id of punk::args definition for a command" - - - @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" - withdef -type literal -help\ - "The literal value 'withdef'" - - #todo - make -dynamic obsolete - use @dynamic directive instead - def -type string -multiple 1 -optional 0 -help\ - "Each remaining argument is a block of text - defining argument definitions. - As a special case, -dynamic may be - specified as the 1st 2 arguments. These are - treated as an indicator to punk::args about - how to process the definition." - - }] - proc parse {args} { - set tailtype "" ;#withid|withdef - if {[llength $args] < 3} { - error "punk::args::parse - invalid call. < 3 args" - } - set parseargs [lindex $args 0] - set tailargs [lrange $args 1 end] - - set split [lsearch -exact $tailargs withid] - if {$split < 0} { - set split [lsearch -exact $tailargs withdef] - if {$split < 0} { - #punk::args::usage arg_error? - error "punk::args::parse - invalid call. keyword withid|withdef required" - } else { - set tailtype withdef - } - } else { - set tailtype withid - } - - set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. - if {[llength $opts] % 2} { - error "punk::args::parse Even number of -flag val pairs required after arglist" - } - - #Default the -errorstyle to enhanced - # (slowest on unhappy path - but probably clearest for playing with new APIs interactively) - # - application devs should distribute a config file with an errorstyle override if desired. - # - devs who prefer a different default for interactive use should create a config for it. (todo) - set defaultopts [dict create\ - -form {*}\ - -errorstyle enhanced\ - ] - - #todo - load override_errorstyle from configuration - #dict set defaultopts -errorstyle $ - - set opts [dict merge $defaultopts $opts] - dict for {k v} $opts { - switch -- $k { - -form - -errorstyle { - } - default { - #punk::args::usage $args withid ::punk::args::parse ?? - error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" - } - } - } - switch -- $tailtype { - withid { - if {[llength [lrange $tailargs $split+1 end]] != 1} { - error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - } - set id [lindex $tailargs $split+1] - #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" - set deflist [raw_def $id] - if {[llength $deflist] == 0} { - error "punk::args::parse - no such id: $id" - } - } - withdef { - set deflist [lrange $tailargs $split+1 end] - if {[llength $deflist] < 1} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" - } - default { - error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" - } - } - try { - set result [punk::args::get_dict {*}$deflist $parseargs] - } trap {PUNKARGS VALIDATION} {msg erroropts} { - set opt_errorstyle [dict get $opts -errorstyle] - - #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - - - set ecode [dict get $erroropts -errorcode] - #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... - set msg [string map [list %caller% [Get_caller]] $msg] - switch -- $opt_errorstyle { - minimal { - return -options [list -code error -errorcode $ecode] $msg - } - basic { - #No table layout - unix manpage style - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg] - } - return -options [list -code error -errorcode $ecode] $msg - } - standard { - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg] - } - return -options [list -code error -errorcode $ecode] $msg - } - enhanced { - set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below) - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - set ecode_summary [lrange $ecode 0 2] - if {$badarg ne ""} { - lappend ecode_summary -badarg $badarg - } - catch {package require punk::lib} - if {[package provide punk::lib] ne ""} { - append msg \n [punk::lib::showdict -roottype list $estack */*] - } - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg] - append msg \n "::errorCode summary: $ecode_summary" - return -options [list -code error -errorcode $ecode] $msg - } else { - #why? todo? - append msg \n "(enhanced error information unavailable)" - append msg \n "::errorCode summary: $ecode_summary" - return -options [list -code error -errorcode $ecode] $msg - } - } - debug { - puts stderr "errorstyle debug not implemented" - return -options [list -code error -errorcode $ecode] $msg - } - } - } trap {PUNKARGS} {msg erropts} { - append msg \n "Unexpected PUNKARGS error" - return -options [list -code error -errorcode $ecode] $msg - } trap {} {msg erroropts} { - #review - #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. - #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. - throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] - } - return $result - } - proc parseXXX {args} { - #no solo flags allowed for parse function itself. (ok for arglist being parsed) - set opts [dict create] ;#repeated flags will override earlier. That's ok here. - set arglist {} - set got_arglist 0 - set tailtype "" ;#withid|withdef - set id "" - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {[string match -* $a]} { - dict set opts $a [lindex $args $i+1] - incr i - } else { - set arglist $a - set got_arglist 1 - set tailtype [lindex $args $i+1] - if {$tailtype eq "withid"} { - if {[llength $args] != $i+3} { - error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - } - set id [lindex $args $i+2] - break - } elseif {$tailtype eq "withdef"} { - if {[llength $args] < $i+3} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - set deflist [lrange $args $i+2 end] - break - } else { - error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" - } - } - } - if {!$got_arglist} { - error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." - } - #assert tailtype eq withid|withdef - if {$tailtype eq "withid"} { - #assert $id was provided - return "parse [llength $arglist] args withid $id, options:$opts" - } else { - #assert llength deflist >=1 - return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" - } - #TODO - } - - #todo? - a version of get_dict that directly supports punk::lib::tstr templating - #rename get_dict - # - - #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 get_dict {args} { - #see arg_error regarding considerations around unhappy-path performance - - #consider a better API - # - e.g punk::args::parse ?-flag val?... $arglist withid $id - # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? - #can the above be made completely unambiguous for arbitrary arglist?? - #e.g what if arglist = withdef and the first $def is also withdef ? - - - #*** !doctools - #[call [fun get_dict] [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 values - #[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 defining a flag 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 - #[para]Each optionspec line defining a positional argument is of the form: - #[para]argumentname -key val -ky2 val2... - #[para]where the valid keys for each option specification are: -default -type -range -choices - #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value - #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. - #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. - #[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, - #but it could be a manually constructed list of values made for example from positional args defined in the proc. - #[list_end] - #[para] - - #consider line-processing example below for which we need info complete to determine record boundaries - #punk::args::get_dict { - # @opts - # -opt1 -default {} - # -opt2 -default { - # etc - # } - # @values -multiple 1 - #} $args - - set rawargs [lindex $args end] ;# args values to be parsed - #we take a definition list rather than argspecs - because the definition could be dynamic - set definition_args [lrange $args 0 end-1] - - #if definition has been seen before, - #define will either return a permanently cached argspecs (-dynamic 0) - or - # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. - set argspecs [uplevel 1 [list ::punk::args::resolve {*}$definition_args]] - - # ----------------------------------------------- - # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) - tcl::dict::with argspecs {} ;#turn keys into vars - # TODO - capitalise 'define' vars to make it a bit easier - # ----------------------------------------------- - - #puts "-arg_info->$arg_info" - set flagsreceived [list] ;#for checking if required flags satisfied - set solosreceived [list] - #secondary purpose: - #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 ? - - # -- --- --- --- - # Handle leading positionals - # todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ? - set opts $opt_defaults - set pre_values {} - - set argnames [tcl::dict::keys $ARG_INFO] - set optnames [lsearch -all -inline $argnames -*] - set ridx 0 - set rawargs_copy $rawargs - set leader_posn_name "" - set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) - set is_multiple 0 ;#last leader may be multi - if {$LEADER_MAX != 0} { - foreach r $rawargs_copy { - if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { - break - } - if {$ridx == [llength $LEADER_NAMES]-1} { - #at last named leader - set leader_posn_name [lindex $LEADER_NAMES $ridx] - if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { - set is_multiple 1 - } - } elseif {$ridx > [llength $LEADER_NAMES]-1} { - #beyond names - retain name if -multiple was true - if {!$is_multiple} { - set leader_posn_name "" - } - } else { - set leader_posn_name [lindex $LEADER_NAMES $ridx] ;#may return empty string - } - if {$r eq "--"} { - #review end of opts marker: '--' can't be a leader (but can be a value) - break - } - - #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option - if {[tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { - set matchopt [::tcl::prefix::match -error {} $optnames $r] - if {$matchopt ne ""} { - #flaglike matches a known flag - don't treat as leader - break - } - #if {![string match -* [lindex $argnames $ridx]]} {} - if {$leader_posn_name ne ""} { - #there is a named leading positional for this position - #The flaglooking value doesn't match an option - so treat as a leader - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - incr ridx - continue - } else { - break - } - } - - #for each branch - break or lappend - if {$leader_posn_name ne ""} { - if {$leader_posn_name ni $LEADER_REQUIRED} { - #optional leader - - #most adhoc arg processing will allocate based on number of args rather than matching choice values first - #(because a choice value could be a legitimate data value) - - #review - option to process in this manner? - #first check if the optional leader value is a match for a choice ? - #if {[dict exists $arg_info $leader_posn_name -choices]} { - # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] [lindex $rawargs 0]] - # if {$vmatch ne ""} { - # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values - # lappend pre_values [lpop rawargs 0] - # incr ridx - # continue - # } - #} - - #check if enough rawargs to fill any required values - if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { - break - } else { - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #required - if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { - #already accepted at least one value - requirement satisfied - now equivalent to optional - if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { - break - } - } - #if we didn't break - requirement is not yet satisfied, or is satisfied but stil enough rawargs for required values - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #unnamed leader - if {$LEADER_MIN ne "" } { - if {$ridx > $LEADER_MIN} { - break - } else { - #haven't reached LEADER_MIN - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - break - } - } - - incr ridx - } ;# end foreach r $rawargs_copy - } - - set argstate $ARG_INFO ;#argstate may have entries added - set arg_checks $ARG_CHECKS - - if {$LEADER_MIN eq ""} { - set leadermin 0 - } else { - set leadermin $LEADER_MIN - } - if {$LEADER_MAX eq ""} { - set leadermax -1 - } else { - set leadermax $LEADER_MAX - } - - #assert leadermax leadermin are numeric - #assert - rawargs has been reduced by leading positionals - - set leaders [list] - set arglist {} - set post_values {} - #val_min, val_max - #puts stderr "rawargs: $rawargs" - #puts stderr "argstate: $argstate" - if {[lsearch $rawargs -*] >= 0} { - #at least contains flaglike things.. - set maxidx [expr {[llength $rawargs] -1}] - if {$val_max == -1} { - set vals_total_possible [llength $rawargs] - set vals_remaining_possible $vals_total_possible - } else { - set vals_total_possible $val_max - set vals_remaining_possible $vals_total_possible - } - for {set i 0} {$i <= $maxidx} {incr i} { - set a [lindex $rawargs $i] - set remaining_args_including_this [expr {[llength $rawargs] - $i}] - #lowest val_min is 0 - if {$remaining_args_including_this <= $val_min} { - # if current arg is -- it will pass through as a value here - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - - #exlude argument with whitespace from being a possible option e.g dict - if {[tcl::string::match -* $a] && !([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { - if {$a eq "--"} { - #remaining num args <= val_min already covered above - if {$val_max != -1} { - #finite max number of vals - if {$remaining_args_including_this == $val_max} { - #assume it's a value. - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - } else { - #assume it's an end-of-options marker - lappend flagsreceived -- - set arglist [lrange $rawargs 0 $i] - set post_values [lrange $rawargs $i+1 end] - } - } else { - #unlimited number of post_values accepted - #treat this as eopts - we don't care if remainder look like options or not - lappend flagsreceived -- - set arglist [lrange $rawargs 0 $i] - set post_values [lrange $rawargs $i+1 end] - } - break - } else { - set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] - if {$fullopt ne ""} { - if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { - #non-solo - #check if it was actually a value that looked like a flag - if {$i == $maxidx} { - #if no optvalue following - assume it's a value - #(caller should probably have used -- before it) - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - - set flagval [lindex $rawargs $i+1] - if {[tcl::dict::get $argstate $fullopt -multiple]} { - #don't lappend to default - we need to replace if there is a default - if {$fullopt ni $flagsreceived} { - tcl::dict::set opts $fullopt [list $flagval] - } else { - tcl::dict::lappend opts $fullopt $flagval - } - } else { - tcl::dict::set opts $fullopt $flagval - } - #incr i to skip flagval - incr vals_remaining_possible -2 - if {[incr i] > $maxidx} { - set msg "Bad options for %caller%. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $fullopt index [expr {$i-1}]] -badarg $fullopt -argspecs $argspecs]] $msg - #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $fullopt - } - } else { - #solo - if {[tcl::dict::get $argstate $fullopt -multiple]} { - if {$fullopt ni $flagsreceived} { - #override any default - don't lappend to it - tcl::dict::set opts $fullopt 1 - } else { - tcl::dict::lappend opts $fullopt 1 - } - } else { - tcl::dict::set opts $fullopt 1 - } - incr vals_remaining_possible -1 - lappend solosreceived $fullopt ;#dups ok - } - lappend flagsreceived $fullopt ;#dups ok - } else { - #unmatched option flag - #comparison to val_min already done above - if {$val_max ne -1 && $remaining_args_including_this <= $val_max} { - #todo - look at optspec_default and see if solo/vs opt-val pair - #we may need to lookahead by 2 regarding val_max val_min - - #even with optany - assume an unknown within the space of possible values is a value - #unmatched option in right position to be considered a value - treat like eopts - #review - document that an unspecified arg within range of possible values will act like eopts -- - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - if {$opt_any} { - set newval [lindex $rawargs $i+1] - #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option - tcl::dict::set argstate $a $optspec_defaults ;#use default settings for unspecified opt - tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS - if {[tcl::dict::get $argstate $a -type] ne "none"} { - if {[tcl::dict::get $argstate $a -multiple]} { - tcl::dict::lappend opts $a $newval - } else { - tcl::dict::set opts $a $newval - } - if {[incr i] > $maxidx} { - set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg - #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a - } - incr vals_remaining_possible -2 - } else { - #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none - if {[tcl::dict::get $argstate $a -multiple]} { - if {![tcl::dict::exists $opts $a]} { - tcl::dict::set opts $a 1 - } else { - tcl::dict::lappend opts $a 1 - } - } else { - tcl::dict::set opts $a 1 - } - incr vals_remaining_possible -1 - lappend solosreceived $a - } - lappend flagsreceived $a ;#adhoc flag as supplied - } else { - if {[llength $OPT_NAMES]} { - set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" - } else { - set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" - } - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg - #arg_error $errmsg $argspecs -badarg $fullopt - } - } - } - } else { - #not flaglike - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - } - #set values [list {*}$pre_values {*}$post_values] - set leaders $pre_values - set values $post_values - } else { - set leaders $pre_values - set values $rawargs - #set values [list {*}$pre_values {*}$rawargs] ;#no -flags detected - set arglist [list] - } - #puts stderr "--> arglist: $arglist" - #puts stderr "--> values: $values" - - - set positionalidx 0 ;#index for unnamed positionals (both leaders and values) - set ldridx 0 - set in_multiple "" - set leadernames_received [list] - set leaders_dict $LEADER_DEFAULTS - set num_leaders [llength $leaders] - foreach leadername $LEADER_NAMES ldr $leaders { - if {$ldridx+1 > $num_leaders} { - break - } - if {$leadername ne ""} { - if {[tcl::dict::get $argstate $leadername -multiple]} { - if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { - tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list - } else { - tcl::dict::lappend leaders_dict $leadername $ldr - } - set in_multiple $leadername - } else { - tcl::dict::set leaders_dict $leadername $ldr - } - lappend leadernames_received $leadername - } else { - if {$in_multiple ne ""} { - tcl::dict::lappend leaders_dict $in_multiple $ldr - lappend leadernames_received $in_multiple ;#deliberately allow dups! (as with opts and values) - } else { - tcl::dict::set leaders_dict $positionalidx $ldr - tcl::dict::set argstate $positionalidx $leaderspec_defaults - tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS - lappend leadernames_received $positionalidx - } - } - incr ldridx - incr positionalidx - } - - set validx 0 - set in_multiple "" - set valnames_received [list] - set values_dict $val_defaults - set num_values [llength $values] - foreach valname $VAL_NAMES val $values { - if {$validx+1 > $num_values} { - break - } - if {$valname ne ""} { - if {[tcl::dict::get $argstate $valname -multiple]} { - if {[tcl::dict::exists $val_defaults $valname]} { - #current stored val equals defined default - don't include default in the list we build up - tcl::dict::set values_dict $valname [list $val] ;#important to treat first element as a list - } else { - tcl::dict::lappend values_dict $valname $val - } - set in_multiple $valname - } else { - tcl::dict::set values_dict $valname $val - } - lappend valnames_received $valname - } else { - if {$in_multiple ne ""} { - tcl::dict::lappend values_dict $in_multiple $val - #name already seen - but must add to valnames_received anyway (as with opts and leaders) - lappend valnames_received $in_multiple - } else { - tcl::dict::set values_dict $positionalidx $val - tcl::dict::set argstate $positionalidx $valspec_defaults - tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS - lappend valnames_received $positionalidx - } - } - incr validx - incr positionalidx - } - - if {$leadermax == -1} { - #only check min - if {$num_leaders < $leadermin} { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected at least $leadermin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leadermin" $argspecs - } - } else { - if {$num_leaders < $leadermin || $num_leaders > $leadermax} { - if {$leadermin == $leadermax} { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected exactly $leadermin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leadermin" $argspecs - } else { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - #arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" $argspecs - } - } - } - - if {$val_max == -1} { - #only check min - if {$num_values < $val_min} { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $val_min" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg - #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected at least $val_min" $argspecs - } - } else { - if {$num_values < $val_min || $num_values > $val_max} { - if {$val_min == $val_max} { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $val_min" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg - #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected exactly $val_min" $argspecs - } else { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $val_min and $val_max inclusive" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $val_min max $val_max] -argspecs $argspecs]] $msg - #arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected between $val_min and $val_max inclusive" $argspecs - } - } - } - - #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options - - - #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 SHOULD? 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 - - #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? - #example timing difference: - #struct::set difference {x} {a b} - #normal interp 0.18 u2 vs safe interp 9.4us - #if {[llength [set missing [struct::set difference $opt_required $flagsreceived]]]} { - # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" - #} - #if {[llength [set missing [struct::set difference $val_required $valnames_received]]]} { - # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" - #} - #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us - if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { - set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadermissing $missing received $leadernames_received] -argspecs $argspecs]] $msg - #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - if {[llength [set missing [punklib_ldiff $opt_required $flagsreceived]]]} { - set msg "Required option missing for %caller%. missing flags: '$missing' are marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list optionmissing $missing received $flagsreceived] -argspecs $argspecs]] $msg - #arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs - } - if {[llength [set missing [punklib_ldiff $val_required $valnames_received]]]} { - set msg "Required value missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list valuemissing $missing received $valnames_received] -argspecs $argspecs]] $msg - #arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - - - #todo - truncate/summarize values in error messages - - #todo - allow defaults outside of choices/ranges - - #check types,ranges,choices - set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] - #set combined_defaults [tcl::dict::merge $val_defaults $opt_defaults] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash - #puts "---opts_and_values:$opts_and_values" - #puts "---argstate:$argstate" - tcl::dict::for {argname v} $opts_and_values { - set thisarg [tcl::dict::get $argstate $argname] - #set thisarg_keys [tcl::dict::keys $thisarg] - set thisarg_checks [tcl::dict::get $arg_checks $argname] - set is_multiple [tcl::dict::get $thisarg -multiple] - set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] - set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] - set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] - set has_default [tcl::dict::exists $thisarg -default] - if {$has_default} { - set defaultval [tcl::dict::get $thisarg -default] - } - set type [tcl::dict::get $thisarg -type] - set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] - set regexprepass [tcl::dict::get $thisarg -regexprepass] - set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 - set validationtransform [tcl::dict::get $thisarg -validationtransform] - - - if {$is_multiple} { - set vlist $v - } else { - set vlist [list $v] - } - set vlist_original $vlist ;#retain for possible final strip_ansi - - #review - validationtransform - if {$is_validate_ansistripped} { - #validate_ansistripped 1 - package require punk::ansi - set vlist_check [list] - foreach e $vlist { - lappend vlist_check [punk::ansi::ansistrip $e] - } - } else { - #validate_ansistripped 0 - set vlist_check $vlist - } - - #reduce our validation requirements by removing values which match defaultval or match -choices - #(could be -multiple with -choicerestriction 0 where some selections match and others don't) - if {$has_choices} { - #-choices must also work with -multiple - #todo -choicelabels - set choiceprefix [tcl::dict::get $thisarg -choiceprefix] - set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] - set choicerestricted [tcl::dict::get $thisarg -choicerestricted] - set choicemultiple [tcl::dict::get $thisarg -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set nocase [tcl::dict::get $thisarg -nocase] - set choices [Dict_getdef $thisarg -choices {}] - set choicegroups [Dict_getdef $thisarg -choicegroups {}] - set allchoices $choices - if {[dict size $choicegroups]} { - dict for {groupname groupmembers} $choicegroups { - lappend allchoices {*}$groupmembers - } - } - #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups - #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes - - - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - set dname leaders_dict - } - option { - set dname opts - } - value { - set dname values_dict - } - } - set idx 0 ;# - #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes - #assert llength $vlist == llength [dict get $dname $argname] - # (unless there was a default and the option wasn't specified) - set vlist_validate [list] - set vlist_check_validate [list] - foreach e $vlist e_check $vlist_check { - set allchoices_in_list 0 - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - #vlist and vlist_check can be list of lists if -multiple and -choicemultiple - #each e represents 0 or more choice selections - set c_list $e - set c_check_list $e_check - #todo? check if entire list matches default? - } else { - #only one choice at a time - ensure single entry in c_list c_check_list - set c_list [list $e] - set c_check_list [list $e_check] - } - - - #----------------------------------- - #fast fail on the wrong number of choices - if {[llength $c_list] < $choicemultiple_min} { - set msg "Option $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { - set msg "Option $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - #----------------------------------- - - set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list - foreach c $c_list c_check $c_check_list { - if {$nocase} { - set casemsg " (case insensitive)" - set choices_test [tcl::string::tolower $allchoices] - #Don't lcase the denylist - even in nocase mode! - #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] - set v_test [tcl::string::tolower $c_check] - } else { - set casemsg " (case sensitive)" - set v_test $c_check - set choices_test $allchoices - } - set choice_in_list 0 - set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? - if {!$matches_default} { - if {$choiceprefix} { - #can we handle empty string as a choice? It should just work - REVIEW/test - set choice_exact_match 0 - if {$c_check in $allchoices} { - #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing - set chosen $c_check - set choice_in_list 1 - set choice_exact_match 1 - } elseif {$v_test in $choices_test} { - #assert - if we're here, nocase must be true - #we know choice is present as full-length match except for case - #now we want to select the case from the choice list - not the supplied value - #we don't set choice_exact_match - because we will need to override the optimistic existing val below - #review - foreach avail [lsort -unique $allchoices] { - if {[string match -nocase $c $avail]} { - set chosen $avail - } - } - #assert chosen will always get set - set choice_in_list 1 - } else { - #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. - #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. - #in this block we can treat empty result from prefix match as a non-match - if {$nocase} { - #nocase implies that our entered value doesn't have to match case of choices - - #but we would still like to select the best match if there are case-dups. - #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete - # selecting Del will find Delete, del will match delete (and raise error) - # but DEL will also match delete rather than Delete - so again an error is raised. - #This is counterintuitive with -nocase - #This is probably such an edge case that best served with documentation as a feature-not-bug - #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? - #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. - - set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] - if {$bestmatch eq ""} { - set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] - #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing - set chosen [lsearch -inline -nocase $allchoices $chosen] - set choice_in_list [expr {$chosen ne ""}] - } else { - set chosen $bestmatch - set choice_in_list 1 - } - } else { - set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] - if {$chosen eq ""} { - set choice_in_list 0 - } else { - set choice_in_list 1 - } - } - #override choice_in_list if in deny list - #don't allow prefixing for elements from -choiceprefixdenylist - #we still use all elements to calculate the prefixes though - #review - case difference edge cases in choiceprefixdenylist !todo - if {$chosen in $choiceprefixdenylist} { - set choice_in_list 0 - set chosen "" - } - } - - #override the optimistic existing val - if {$choice_in_list && !$choice_exact_match} { - if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { - if {$is_multiple} { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $idx $chosen - tcl::dict::set $dname $argname $existing - } else { - tcl::dict::set $dname $argname $chosen - } - } else { - if {$is_multiple} { - set existing_all [tcl::dict::get [set $dname] $argname] - lset existing_all $idx $choice_idx $chosen - tcl::dict::set $dname $argname $existing_all - } else { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $choice_idx $chosen - tcl::dict::set $dname $argname $existing - } - } - } - } else { - #value as stored in $dname is ok - set choice_in_list [expr {$v_test in $choices_test}] - } - } - - if {!$choice_in_list && !$matches_default} { - if {!$choicerestricted} { - #if {$is_multiple} { - # set existing [tcl::dict::get [set $dname] $argname] - # lset existing $idx $v_test - # tcl::dict::set $dname $argname $existing - #} else { - # tcl::dict::set $dname $argname $v_test - #} - lappend vlist_validate $c - lappend vlist_check_validate $c_check - } else { - #unhappy path - if {$choiceprefix} { - set prefixmsg " (or a unique prefix of a value)" - } else { - set prefixmsg "" - } - #review: $c vs $c_check for -badval? - set msg "Option '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname - } - } - incr choice_idx - } - - incr idx - } - #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation - #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - - if {[llength $vlist] && $has_default} { - set vlist_validate [list] - set vlist_check_validate [list] - foreach c $vlist c_check $vlist_check { - #for -choicemultiple with default that could be a list use 'ni' ?? review - if {$c_check ne $defaultval} { - lappend vlist_validate $c - lappend vlist_check_validate $c - } - } - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - - #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups - #assert: our vlist & vlist_check lists have been reduced to remove those - if {[llength $vlist] && !$is_allow_ansi} { - #allow_ansi 0 - package require punk::ansi - #do not run ta::detect on a list - foreach e $vlist { - if {[punk::ansi::ta::detect $e]} { - set msg "Option '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg - #error "Option $argname for [Get_caller] contains ansi - but -allow_ansi is false. Received: '$e'" - } - } - } - #puts "argname:$argname v:$v is_default:$is_default" - #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. - #arguments that are at their default are not subject to type and other checks - - #don't validate defaults or choices that matched - #puts "---> opts_and_values: $opts_and_values" - #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" - #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} - - #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups - #assert [llength $vlist] == [llength $vlist_check] - if {[llength $vlist]} { - switch -- $type { - any {} - list { - foreach e_check $vlist_check { - if {![tcl::string::is list -strict $e_check]} { - set msg "Option '$argname' for %caller% requires type 'list'. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires type 'list'. Received: '$e_check'" $argspecs -badarg $argname - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[llength $e_check] < $checkval} { - set msg "Option '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e -badval $e_check -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires list with -minsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[llength $e_check] > $checkval} { - set msg "Option '$argname for %caller% requires list with -maxsize $checkval. Received len:[llength $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $e -badval $e_check -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires list with -maxsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - } - } - } - } - } - } - string - ansistring - globstring { - #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string - #we possibly don't want to always have to regex on things that don't pass the other more basic checks - # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) - # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) - # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead - # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function - # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) - # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail - - #todo? - way to validate both unstripped and stripped? - set pass_quick_list_e [list] - set pass_quick_list_e_check [list] - set remaining_e $vlist - set remaining_e_check $vlist_check - #review - order of -regexprepass and -regexprefail in original rawargs significant? - #for now -regexprepass always takes precedence - if {$regexprepass ne ""} { - foreach e $vlist e_check $vlist_check { - if {[regexp $regexprepass $e]} { - lappend pass_quick_list_e $e - lappend pass_quick_list_e_check $e_check - } - } - set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] - set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] - } - if {$regexprefail ne ""} { - foreach e $remaining_e e_check $remaining_e_check { - #puts "----> checking $e vs regex $regexprefail" - if {[regexp $regexprefail $e]} { - if {[tcl::dict::exists $thisarg -regexprefailmsg]} { - #review - %caller% ?? - set msg [tcl::dict::get $thisarg -regexprefailmsg] - } else { - set msg "Option $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" - } - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $e -argspecs $argspecs]] $msg - #arg_error $msg $argspecs -badarg $argname - } - } - } - switch -- $type { - ansistring { - #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi - #.. so we need to look at the original values in $vlist not $vlist_check - - #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? - #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? - package require punk::ansi - foreach e $remaining_e { - if {![punk::ansi::ta::detect $e]} { - set msg "Option '$argname' for %caller% requires ansistring - but no ansi detected" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires ansistring - but no ansi detected" $argspecs -badarg $argname - } - } - } - globstring { - foreach e $remaining_e { - if {![regexp {[*?\[\]]} $e]} { - set msg "Option '$argname' for %caller% requires globstring - but no glob characters detected" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires globstring - but no glob characters detected" $argspecs -badarg $argname - } - } - } - } - - if {[tcl::dict::size $thisarg_checks]} { - foreach e_check $remaining_e_check { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[tcl::string::length $e_check] < $checkval} { - set msg "Option '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::string::length $e_check] > $checkval} { - set msg "Option '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - } - } - } - } - } - } - int { - #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive - if {[tcl::dict::exists $thisarg -range]} { - lassign [tcl::dict::get $thisarg -range] low high - if {"$low$high" ne ""} { - if {$low eq ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error "Option '$argname' for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname - } - #lowside unspecified - check only high - if {$e_check > $high} { - set msg "Option '$argname' for %caller% must be integer greater than or equal to $hight. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error "Option '$argname' for [Get_caller] must be integer less than or equal to $high. Received: '$e'" $argspecs -badarg $argname - } - } - } elseif {$high eq ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname - } - #highside unspecified - check only low - if {$e_check < $low} { - set msg "Option '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs -badarg $argname - } - } - } else { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "Option '$argname' for %caller% requires type 'integer'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname - } - #high and low specified - if {$e_check < $low || $e_check > $high} { - set msg "Option '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs -badarg $argname - } - } - } - } - } else { - foreach e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "Option $argname for %caller% requires type integer. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e_check'" $argspecs -badarg $argname - } - } - } - } - double { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is double -strict $e_check]} { - set msg "Option $argname for %caller% requires type double. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - #error "Option $argname for [Get_caller] requires type 'double'. Received: '$e'" - } - if {[tcl::dict::size $thisarg_checks]} { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -range { - #todo - small-value double comparisons with error-margin? review - #todo - empty string for low or high - lassign $checkval low high - if {$e_check < $low || $e_check > $high} { - set msg "Option $argname for %caller% must be double between $low and $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] must be between $low and $high. Received: '$e'" $argspecs -badarg $argname - } - } - } - } - } - } - } - bool { - foreach e_check $vlist_check { - if {![tcl::string::is boolean -strict $e_check]} { - set msg "Option $argname for %caller% requires type boolean. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires type 'boolean'. Received: '$e_check'" $argspecs -badarg $argname - } - } - } - dict { - foreach e_check $vlist_check { - if {[llength $e_check] %2 != 0} { - set msg "Option '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires type 'dict' - must be key value pairs. Received: '$e_check'" $argspecs -badarg $argname - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[tcl::dict::size $e_check] < $checkval} { - set msg "Option '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires dict with -minsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::dict::size $e_check] > $checkval} { - set msg "Option '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires dict with -maxsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - } - } - } - } - } - } - alnum - - alpha - - ascii - - control - - digit - - graph - - lower - - print - - punct - - space - - upper - - wordchar - - xdigit { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is $type $e_check]} { - #set msg "Option $argname for [Get_caller] requires type '$type'. Received: '$e'" - #try trap? - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type]]] $result - #throw ? - set msg "Option $argname for %caller% requires type '$type'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error $msg $argspecs -badarg $argname - } - } - } - file - - directory - - existingfile - - existingdirectory { - foreach e $vlist e_check $vlist_check { - #//review - we may need '?' char on windows - if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { - #what about special file names e.g on windows NUL ? - set msg "Option $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" $argspecs -badarg $argname - } - } - if {$type eq "existingfile"} { - foreach e $vlist e_check $vlist_check { - if {![file exists $e_check]} { - set msg "Option $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing file" $argspecs -badarg $argname - } - } - } elseif {$type eq "existingdirectory"} { - foreach e $vlist e_check $vlist_check { - if {![file isdirectory $e_check]} { - set msg "Option $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing directory" $argspecs -badarg $argname - } - } - } - } - char { - #review - char vs unicode codepoint vs grapheme? - foreach e $vlist e_check $vlist_check { - if {[tcl::string::length $e_check] != 1} { - set msg "Option $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] requires type 'character'. Received: '$e' which is not a single character" $argspecs -badarg $argname - } - } - } - } - - } - - if {$is_strip_ansi} { - set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach - if {[tcl::dict::get $thisarg -multiple]} { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict $argname $stripped_list - } - option { - tcl::dict::set opts $argname $stripped_list - } - value { - tcl::dict::set values_dict $argname $stripped_list - } - } - } else { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict [lindex $stripped_list 0] - } - option { - tcl::dict::set opts $argname [lindex $stripped_list 0] - } - value { - tcl::dict::set values_dict [lindex $stripped_list 0] - } - } - } - } - } - - #maintain order of opts $opts values $values as caller may use lassign. - set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] - if {[llength $receivednames]} { - #flat zip of names with overall posn, including opts - #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] - set i -1 - set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] - } else { - set received_posns [list] - } - #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) - #(e.g using 'dict exists $received -flag') - # - but it can have duplicate keys when args/opts have -multiple 1 - #It is actually a list of paired elements - return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived] - } - - #proc sample1 {p1 args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [opt {?option value...?}]] - # #[para]Description of sample1 - # return "ok" - #} - - - lappend PUNKARGS [list { - @id -id ::punk::args::TEST - @opts -optional 0 - -o1 -default 111 -help "opt 1 mandatory" - @opts -optional 1 - -o2 -default 222 -help "opt 2 optional" - @values -min 0 -max 1 - v -help\ - "v1 optional" - }] - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::lib { - variable PUNKARGS - tcl::namespace::export * - tcl::namespace::path [list [tcl::namespace::parent]] - #*** !doctools - #[subsection {Namespace punk::args::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 flatzip {l1 l2} { - concat {*}[lmap a $l1 b $l2 {list $a $b}] - } - - if {[info commands lseq] ne ""} { - #tcl 8.7+ lseq significantly faster, especially for larger ranges - #The internal rep can be an 'arithseries' with no string representation - proc zero_based_posns {count} { - if {$count < 1} {return} - lseq 0 $count-1 - } - } else { - proc zero_based_posns {count} { - if {$count < 1} {return} - lsearch -all [lrepeat $count 0] * - } - } - - - #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 -1] in calling scope ${[lindex [set x] 0]} !} - lappend PUNKARGS [list { - @id -id ::punk::args::lib::tstr - @cmd -name punk::args::lib::tstr -help\ - "A rough equivalent of js template literals - - Substitutions: - \$\{$varName\} - \$\{[myCommand]\} - (when -allowcommands flag is given)" - -allowcommands -default 0 -type none -help\ - "If -allowcommands is present, placeholder can contain commands - e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" - -undent -default 1 -type boolean -help\ - "undent/dedent the template lines. - The longest common prefix of whitespace is removed" - -indent -default "" -type string -help\ - "String with which to indent the template - prior to substitution. - If -undent is enabled, that is performed - first, then the indent is applied." - -paramindents -default line -choices {none line position} -choicelabels { - line\ - " Use leading whitespace in - the line in which the - placeholder occurs." - position\ - " Use the position in - the line in which the - placeholder occurs." - none\ - " No indents applied to - subsequent placeholder value - lines. This will usually - result in text awkwardly - ragged unless the source code - has also been aligned with the - left margin or the value has - been manually padded." - } -help\ - "How indenting is done for subsequent lines in a - multi-line placeholder substitution value. - The 1st line or a single line value is always - placed at the placeholder. - paramindents are performed after the main - template has been indented/undented. - (indenting by position does not calculate - unicode double-wide or grapheme cluster widths) - " - #choicelabels indented by 1 char is clearer for -return string - and reasonable in table - -return -default string -choices {dict list string args}\ - -choicelabels { - dict\ - " Return a dict with keys - 'template', 'params' and - 'errors'" - string\ - " Return a single result - being the string with - placeholders substituted." - list\ - " Return a 2 element list. - The first is itself a list - of plaintext portions of the - template, split at each point - at which placeholders were - present. The second element - of the outer list is a list - of placeholder values if -eval - is 1, or a list of the raw - placeholder strings if -eval - is 0." - args\ - " Return a list where the first - element is a list of template - plaintext sections as per the - 'list' return mechanism, but the - placeholder items are individual - items in the returned list. - This can be useful when passing - the expanded result of a tstr - command to another function - which expects the placeholders - as individual arguments" - } - -eval -default 1 -type boolean -help\ - "Whether to evaluate the \$\{\} placeholders. - When -return is string, -eval should generally be set to 1. - For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. - contained variables in that case should be braced or whitespace separated, or the variable - name is likely to collide with surrounding text. - e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" - @values -min 0 -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 - e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} - - Escape sequences such as \\n and unicode escapes are processed within placeholders. - " - }] - - proc tstr {args} { - #Too hard to fully eat-our-own-dogfood from within punk::args package - # - we use punk::args within the unhappy path only - #set argd [punk::args::get_by_id ::punk::lib::tstr $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 opt_eval [dict get $argd opts -eval] - - set templatestring [lindex $args end] - set arglist [lrange $args 0 end-1] - set opts [dict create\ - -allowcommands 0\ - -undent 1\ - -indent ""\ - -paramindents line\ - -eval 1\ - -return string\ - ] - if {"-allowcommands" in $arglist} { - set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] - dict set opts -allowcommands 1 - } - if {[llength $arglist] % 2 != 0} { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr expected option/value pairs prior to last argument" - } - } - dict for {k v} $arglist { - set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] - switch -- $fullk { - -indent - -undent - -paramindents - -return - -eval { - dict set opts $fullk $v - } - default { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" - } - } - } - } - set opt_allowcommands [dict get $opts -allowcommands] - set opt_paramindents [dict get $opts -paramindents] - set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] - if {$test_paramindents ni {none line position}} { - error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." - } - set opt_paramindents $test_paramindents - set opt_return [dict get $opts -return] - set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] - if {$opt_return eq ""} { - } - set opt_eval [dict get $opts -eval] - - - set nocommands "-nocommands" - if {$opt_allowcommands == 1} { - set nocommands "" - } - - set opt_undent [dict get $opts -undent] - if {$opt_undent} { - set templatestring [punk::args::lib::undent $templatestring] - } - set opt_indent [dict get $opts -indent] - if {$opt_indent ne ""} { - set templatestring [punk::args::lib::indent $templatestring $opt_indent] - } - - #set parts [_tstr_split $templatestring] - if {[string first \$\{ $templatestring] < 0} { - set parts [list $templatestring] - } else { - set parts [_parse_tstr_parts $templatestring] - } - set textchunks [list] - #set expressions [list] - set params [list] - set idx 0 - set errors [dict create] - set lastline "" ;#todo - first line has placeholder? - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach {pt expression} $parts { - lappend textchunks $pt - incr idx ;#pt incr - - #ignore last expression - if {$idx == [llength $parts]} { - break - } - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - #lappend expressions $expression - #---------------------- - #REVIEW - JMN - #TODO - debug punk::args loading of @dynamic defs - #puts "-- $expression" - #---------------------- - #brk1 - literal newline not {\n} - set leader "" - if {[set brk1 [string first \n $expression]] >= 0} { - #undent left of paramstart only for lines of expression that arent on opening ${..} line - set tail [string range $expression $brk1+1 end] - set leader [string repeat " " [string length $lastline]] - set undentedtail [punk::args::lib::undentleader $tail $leader] - #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] - set expression "[string range $expression 0 $brk1]$undentedtail" - } - if {$opt_eval} { - if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { - lappend params [string cat \$\{ $expression \}] - dict set errors [expr {[llength $params]-1}] $result - } else { - set result [string map [list \n "\n$leader"] $result] - lappend params $result - } - #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] - } else { - lappend params [subst -nocommands -novariables $expression] - } - append lastline [lindex $params end] ;#for current expression's position calc - - incr idx ;#expression incr - } - - if {$opt_return eq "dict"} { - return [dict create template $textchunks params $params errors $errors] - } - if {[dict size $errors]} { - set einfo "" - dict for {i e} $errors { - append einfo "parameter $i error: $e" \n - } - #REVIEW!!! - #TODO - fix - #puts stderr "tstr errors:\n$einfo\n" - } - - switch -- $opt_return { - list { - return [list $textchunks $params] - } - args { - #see example in tstr_test_one - return [list $textchunks {*}$params] - } - string { - #todo - flag to disable indent-matching behaviour for multiline param? - set out "" - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach pt $textchunks param $params { - if {$opt_paramindents eq "none"} { - append out $pt $param - } else { - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - if {$opt_paramindents eq "line"} { - regexp {(\s*).*} $lastline _all lastindent - } else { - #position - #TODO - detect if there are grapheme clusters - #This regsub doesn't properly space unicode double-wide chars or clusters - set lastindent "[regsub -all {\S} $lastline " "] " - } - if {$lastindent ne ""} { - set paramlines [split $param \n] - if {[llength $paramlines] == 1} { - append out $pt $param - } else { - append out $pt [lindex $paramlines 0] - foreach nextline [lrange $paramlines 1 end] { - append out \n $lastindent $nextline - } - } - } else { - append out $pt $param - } - append lastline $param - } - } - return $out - } - } - } - #test single placeholder tstr args where single placeholder must be an int - proc tstr_test_one {args} { - set argd [punk::args::get_dict { - @cmd -name ::punk::args::lib::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 -return args {Select * from table where id = \$\{$id\} and etc... ;}] - } - - @values -min 2 -max 2 - template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - - but the tstr call in the example 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]] ""] - set result [string cat [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 dollar sign - 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]] - } - - #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. - proc indent {text {prefix " "}} { - set result [list] - foreach line [split $text \n] { - if {[string trim $line] eq ""} { - lappend result "" - } else { - lappend result $prefix[string trimright $line] - } - } - return [join $result \n] - } - #dedent? - proc undent {text} { - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - regexp {^([\t ]*)} $lcp _m lcp - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - - #hacky - proc undentleader {text leader} { - #leader usually whitespace - but doesn't have to be - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - lappend nonblank "${leader}!!" - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - #regexp {^([\t ]*)} $lcp _m lcp - #lcp can be shorter than leader - set lcp [string range $lcp 0 [string length $leader]-1] - - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - #A version of textutil::string::longestCommonPrefixList - proc longestCommonPrefix {items} { - if {[llength $items] <= 1} { - return [lindex $items 0] - } - set items [lsort $items[unset items]] - set min [lindex $items 0] - set max [lindex $items end] - #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) - #(sort order nothing to do with length - e.g min may be longer than max) - if {[string length $min] > [string length $max]} { - set temp $min - set min $max - set max $temp - } - set n [string length $min] - set prefix "" - set i -1 - while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { - append prefix $c - } - return $prefix - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] -} - -tcl::namespace::eval punk::args::argdocbase { - namespace export * - #use a? to test and create literal ansi here rather than relying on punk::ansi package presence - #e.g - #% a? bold - #- bold │SGR 1│sample│␛[1msample - #- ──────┼─────┼──────┼────────── - #- RESULT│ │sample│␛[1msample - proc B {} {return \x1b\[1m} ;#a+ bold - proc N {} {return \x1b\[22m} ;#a+ normal - proc I {} {return \x1b\[3m} ;#a+ italic - proc NI {} {return \x1b\[23m} ;#a+ noitalic - -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::package { - variable PUNKARGS - lappend PUNKARGS [list { - @dynamic - @id -id "::punk::args::package::standard_about" - @cmd -name "%pkg%::about" -help\ - "About %pkg% - ... - " - -package_about_namespace -type string -optional 0 -help\ - "Namespace containing the package about procedures - Must contain " - -return\ - -type string\ - -default table\ - -choices {string table tableobject}\ - -choicelabels { - string\ - "A basic text layout" - table\ - "layout in table borders - (requires package: textblock)" - tableobject\ - "textblock::class::table object instance" - }\ - -help\ - "Choose the return type of the 'about' information" - topic -optional 1\ - -nocase 1\ - -default {*}\ - -choices {Description License Version Contact *}\ - -choicerestricted 0\ - -choicelabels { - - }\ - -multiple 1\ - -help\ - "Topic to display. Omit or specify as * to see all. - If * is included with explicit topics, * represents - the remaining unmentioned topics." - }] - proc standard_about {args} { - set argd [punk::args::parse $args withid ::punk::args::package::standard_about] - lassign [dict values $argd] leaders OPTS values received - - set pkgns [dict get $OPTS -package_about_namespace] - if {[info commands ${pkgns}::package_name] eq ""} { - error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" - } - set pkgname [${pkgns}::package_name] - - set opt_return [dict get $OPTS -return] - set all_topics [${pkgns}::about_topics] - if {![dict exists $received topic]} { - set topics $all_topics - } else { - # * represents all remaining topics not explicitly mentioned. - set val_topics [dict get $values topic] ;#if -multiple is true, this is a list - set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] - set topics [list] - foreach t $val_topics { - if {$t eq "*"} { - foreach a $all_topics { - if {$a ni $explicit_topics} { - lappend topics $a - } - } - } else { - lappend topics $t - } - } - } - if {$opt_return ne "string"} { - package require textblock ;#table support - set is_table 1 - set title [string cat {[} $pkgname {]} ] - set t [textblock::class::table new -title $title] - $t configure -frametype double -minwidth [expr {[string length $title]+2}] - - } else { - set topiclens [lmap t $topics {string length $t}] - set widest_topic [tcl::mathfunc::max {*}$topiclens] - set is_table 0 - set about "$pkgname\n" - append about [string repeat - $widest_topic] \n - } - foreach topic $topics { - if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { - set topic_contents [::${pkgns}::get_topic_$topic] - } else { - set topic_contents "" - } - if {!$is_table} { - set content_lines [split $topic_contents \n] - append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n - foreach ln [lrange $content_lines 1 end] { - append about [format %-${widest_topic}s ""] " " $ln \n - } - } else { - $t add_row [list $topic $topic_contents] - } - } - - if {!$is_table} { - return $about - } else { - if {$opt_return eq "tableobject"} { - return $t - } - set result [$t print] - $t destroy - return $result - } - } - -} - -#usually we would directly call arg definitions near the defining proc, -# so that the proc could directly use the definition in its parsing. -# -#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. -#arguably it may be more processor-cache-efficient to do together like this anyway. - -#can't do this here? - as there is circular dependency with punk::lib -#tcl::namespace::eval punk::args { -# foreach deflist $PUNKARGS { -# punk::args::define {*}$deflist -# } -# set PUNKARGS "" -#} - -lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -tcl::namespace::eval punk::args::system { - #*** !doctools - #[subsection {Namespace punk::args::system}] - #[para] Internal functions that are not part of the API - - #dict get value with default wrapper for tcl 8.6 - if {[info commands ::tcl::dict::getdef] eq ""} { - proc Dict_getdef {dictValue args} { - set keys [lrange $args 0 end-1] - if {[tcl::dict::exists $dictValue {*}$keys]} { - return [tcl::dict::get $dictValue {*}$keys] - } else { - return [lindex $args end] - } - } - } else { - #we pay a minor perf penalty for the wrap - interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef - } - - #name to reflect maintenance - home is punk::lib::ldiff - proc punklib_ldiff {fromlist removeitems} { - if {[llength $removeitems] == 0} {return $fromlist} - set result {} - foreach item $fromlist { - if {$item ni $removeitems} { - lappend result $item - } - } - return $result - } - -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::args [tcl::namespace::eval punk::args { - tcl::namespace::path {::punk::args::lib ::punk::args::system} - variable pkg punk::args - variable version - set version 0.1.4 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.6.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.6.tm deleted file mode 100644 index c3bf04b8..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.6.tm +++ /dev/null @@ -1,6400 +0,0 @@ -# -*- 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: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.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 punk::args 0.1.6 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.1.6] -#[copyright "2024"] -#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] -#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] -#[require punk::args] -#[keywords module proc args arguments parse] -#[description] -#[para]Utilities for parsing proc args - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). -#[para] overview of punk::args -#[subsection Concepts] -#[para]There are 2 main conventions for parsing a proc args list -#[list_begin enumerated] -#[enum] -#[para]leading option-value pairs and flags followed by a list of values (Tcl style) -#[enum] -#[para]leading list of values followed by option-value pairs and flags (Tk style) -#[list_end] -#[para]There are exceptions in both Tcl and Tk commands regarding this ordering -#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style -#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] -#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. -#[para] -#[para]The basic principle is that a call to punk::args::parse is made near the beginning of the proc with a cacheable argument defining the parameters e.g -#[example { -# proc dofilestuff {args} { -# lassign [dict values [punk::args::parse $args withdef { -# @cmd -help "do some stuff with files e.g dofilestuff " -# @opts -type string -# #comment lines ok -# -directory -default "" -# -translation -default binary -# #setting -type none indicates a flag that doesn't take a value (solo flag) -# -nocomplain -type none -# @values -min 1 -max -1 -# }]] leaders opts values -# -# puts "translation is [dict get $opts -translation]" -# foreach f [dict values $values] { -# puts "doing stuff with file: $f" -# } -# } -#}] -#[para]The lines beginning with @ are usually optional in most cases and can be used to set defaults and some extra controls -#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values -#[para]valid @ lines being with @cmd @leaders @opts @values -#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. -#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. -#[para]e.g the result from the punk::args::parse call above may be something like: -#[para] leaders {} opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} -#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments -#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments -#[para]This could also be implemented entirely using args - and the @leaders category of arguments -#[example { -# proc dofilestuff {category args} { -# lassign [dict values [punk::args::parse $args withdef { -# @id -id ::dofilestuff -# -directory -default "" -# -translation -default binary -# -nocomplain -type none -# @values -min 2 -max 2 -# fileA -type existingfile 1 -# fileB -type existingfile 1 -# }]] leaders opts values -# puts "$category fileA: [dict get $values fileA]" -# puts "$category fileB: [dict get $values fileB]" -# } -#}] -#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 -#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored -#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, -#[para] or an additional call could be made to punk::args e.g -#[example { -# punk::args::parse [list $category $another_leading_arg] withdef { -# category -choices {cat1 cat2 cat3} -# another_leading_arg -type boolean -# } -#}] - -#*** !doctools -#[subsection Notes] -#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. -#[para] -#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. -#For functions that are part of an API a package may be more suitable. -#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) -#[example { -# proc test_switch {args} { -# set opts [dict create\\ -# -return "object"\\ -# -frametype "heavy"\\ -# -show_edge 1\\ -# -show_seps 0\\ -# -x a\\ -# -y b\\ -# -z c\\ -# -1 1\\ -# -2 2\\ -# -3 3\\ -# ] -# foreach {k v} $args { -# switch -- $k { -# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { -# dict set opts $k $v -# } -# default { -# error "unrecognised option '$k'. Known options [dict keys $opts]" -# } -# } -# } -# return $opts -# } -#}] -#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. -#[para] -# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. -# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. -#[para]use punk::lib::show_jump_tables to verify that a jump table exists. -#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous -#[example { -# proc test_prefix {args} { -# set opts [dict create\ -# -return string\ -# -frametype \uFFEF\ -# -show_edge \uFFEF\ -# -show_seps \uFFEF\ -# -x a\ -# -y b\ -# -z c\ -# -1 1\ -# -2 2\ -# -3 3\ -# ] -# if {[llength $args]} { -# set knownflags [dict keys $opts] -# } -# foreach {k v} $args { -# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v -# } -# return $opts -# } -#}] -#[para]There are many alternative args parsing packages a few of which are listed here. -#[list_begin enumerated] -#[enum]argp (pure tcl) -#[enum]parse_args (c implementation) -#[enum]argparse (pure tcl *) -#[enum]cmdline (pure tcl) -#[enum]opt (pure tcl) distributed with Tcl but considered deprecated -#[enum]The tcllib set of TEPAM modules (pure tcl) -#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. -#[list_end] -#[para] (* c implementation planned/proposed) -#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. -#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences -#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. -#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. -#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. -#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. -#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -#All ensemble commands are slower in a safe interp as they aren't compiled the same way -#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 -#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. -#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) -#ensembles: array binary clock dict info namespace string -#possibly file too, although that is generally hidden/modified in a safe interp -#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc -#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::args -#[list_begin itemized] -package require Tcl 8.6- -#optional? punk::trie -#optional? punk::textblock -#*** !doctools -#[item] [package {Tcl 8.6-}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -tcl::namespace::eval punk::args::register { - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] cooperative namespace punk::args::register - #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded - #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. - #[list_begin definitions] - - #Although the actual punk::args::define calls are not too sluggish, there could be *many*. - #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, - #especially since a fair proportion may be for documentation purposes rather than parsing args. - - # -- --- --- --- --- --- --- --- - #cooperative with packages that define some punk args but do so lazily - #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first - variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective - if {![info exists ::punk::args::register::NAMESPACES]} { - set ::punk::args::register::NAMESPACES [list] - } - # -- --- --- --- --- --- --- --- - - variable loaded_packages - if {![info exists loaded_packages]} { - set loaded_packages [list] ;#fully loaded - } - variable loaded_info - if {![info exists loaded_info]} { - set loaded_info [dict create] ;#time - } - variable scanned_packages - if {![info exists scanned_packages]} { - set scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages - } - variable scanned_info ;#time and idcount - if {![info exists scanned_info]} { - set scanned_info [dict create] - } - #some packages, e.g punk::args::tclcore document other namespaces. - #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources - variable namespace_docpackages - if {![info exists namespace_docpackages]} { - set namespace_docpackages [dict create] - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::register ---}] -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args { - - - variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. - - tcl::namespace::export {[a-z]*} - variable rawdef_cache - if {![info exists rawdef_cache]} { - set rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} - } - variable id_cache_rawdef - if {![info exists id_cache_rawdef]} { - set id_cache_rawdef [tcl::dict::create] - } - variable id_cache_spec - if {![info exists id_cache_spec]} { - set id_cache_spec [tcl::dict::create] - } - - variable argdefcache_unresolved - if {![info exists argdefcache_unresolved]} { - set argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) - } - - variable argdata_cache - if {![info exists argdata_cache]} { - set argdata_cache [tcl::dict::create] - } - - variable id_counter - if {![info exists id_counter]} { - set id_counter 0 - } - - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] Core API functions for punk::args - #[list_begin definitions] - - #todo - some sort of punk::args::cherrypick operation to get spec from an existing set - #todo - doctools output from definition - - - - - #todo? -synonym/alias ? (applies to opts only not values) - #e.g -background -aliases {-bg} -default White - #review - how to make work with trie prefix - #e.g - # -corner -aliases {-corners} - # -centre -aliases {-center -middle} - #We mightn't want the prefix to be longer just because of an alias - #we should get -co -ce and -m from the above as abbreviations - - set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] - - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::define - #todo @preamble -help "move large block outside of table?" - @cmd -name punk::args::define -help\ - "Accepts a line-based definition of command arguments. - The definition can be supplied as a single text block or multiple as described - in the help information for 'text' below. - - Returns an id which is a key to the stored definition. - The id is taken from the supplied definition's @id -id line, or is an - automatically created id of the form 'autoid_'. - - At the time define is called - just the raw text arguments are stored for the id. - When the id is first used, for example with 'punk::args::parse $args withid $id', - the raw definition is parsed into a stored specifications dictionary. - - This specifications dictionary is structured for (optional) use within commands to - parse and validate the arguments - and is also used when retrieving definitions - (or parts thereof) for re-use. - - This can be used purely for documentation or called within a function to parse a mix - of leading values, switches/flags and trailing values. - - The overhead is favourably comparable with other argument processors - but none are - as fast as minimal code with a switch statement. For toplevel commands where a few - 10s of microseconds is immaterial, the validation and automated error formatting in - a table can be well worthwhile. For inner procs requiring utmost speed, the call can - be made only on the unhappy path when basic processing determines a mismatch - or it - can be left entirely as documentation for interactive use with: i ... - and for synopsis generation with: s ... - - The definition should usually contain an initial line of the form: @id -id ::somecmd - - Blank lines are ignored at the top level, ie if they are not part of another structure. - Similarly - lines at the top level beginning with the # character are ignored. - All other toplevel lines must consist of a leading word followed by paired arguments. - The arguments can be spread over multiple lines and contain lines of near-arbitrary - text if they are properly braced or double quoted and Tcl escaping for inner quotes - or unbalanced braces is maintained. - The line continuation character - (\\ at the end of the line) can be used to continue the set of arguments for - a leading word. - Leading words beginning with the @ character are directives controlling argument - parsing, defaults for subsequent arguments, and help display. - directives include: - %B%@id%N% ?opt val...? - directive-options: -id - %B%@cmd%N% ?opt val...? - directive-options: -name -help - %B%@leaders%N% ?opt val...? - directive-options: -min -max - (used for leading args that come before switches/opts) - %B%@opts%N% ?opt val...? - directive-options: -any - %B%@values%N% ?opt val...? - directive-options: -min -max - (used for trailing args that come after switches/opts) - %B%@form%N% ?opt val...? - directive-options: -form -synopsis - (used for commands with multiple forms) - The -synopsis value allows overriding the auto-calculated - synopsis. - %B%@formdisplay%N% ?opt val...? - directive-options: -header (text for header row of table) - -body (override autogenerated arg info for form) - %B%@doc%N% ?opt val...? - directive-options: -name -url - %B%@seealso%N% ?opt val...? - directive-options: -name -url (for footer - unimplemented) - - Some other options normally present on custom arguments are available - to use with the @leaders @opts @values directives to set defaults - for subsequent lines that represent your custom arguments. - These 3 directives should occur in exactly this order - but can be - repeated with custom argument lines interspersed. - - An @id line can only appear once and should be the first item. - For the commandline usage to be displayed either on parsing error - or using the i .. function - an @id with -id is needed. - - All directives can be omitted, in which case every line represents - a custom leader, value or option. - All will be leaders by default if no options defined. - If options are defined (by naming with leading dash, or explicitly - specifying @opts) then the definitions prior to the options will be - categorised as leaders, and those following the options will be - categorised as values. - - Custom arguments are defined by using any word at the start of a - line that doesn't begin with @ or - - (except that adding an additionl @ escapes this restriction so - that @@somearg becomes an argument named @somearg) - - custom leading args, switches/options (names starting with -) - and trailing values also take spec-options: - - -type - defaults to string. If no other restrictions - are specified, choosing string does the least validation. - recognised types: - none - (used for switches only. Indicates this is - a 'solo' flag ie accepts no value) - int|integer - list - indexexpression - dict - double - bool|boolean - char - file - directory - string - ansistring - globstring - (any of the types accepted by 'string is') - - These all perform some validation checks - - and more.. (todo - document here) - - -optional - (defaults to true for flags/switches false otherwise) - For non flag/switch arguments - all arguments with - -optional true must sit consecutively within their group. - ie all optional leader arguments must be together, and all - optional value arguments must be together. Furthermore, - specifying both optional leaders and optional values will - often lead to ambiguous parsing results. Currently, all - optional non-flg/switch arguments should be either at the - trailing end of leaders or the trailing end of values. - Further unambiguous arrangements of optional args may be - made in future - but are currently considered 'unsupported' - -default - -multiple (for leaders & values defines whether - subsequent received values are stored against the same - argument name - only applies to final leader OR final value) - (for options/flags this allows the opt-val pair or solo - flag to appear multiple times - not necessarily contiguously) - -choices {} - A list of allowable values for an argument. - The -default value doesn't have to be in the list. - If a -type is specified - it doesn't apply to choice members. - It will only be used for validation if the -choicerestricted - option is set to false. If all choices are specified in values - within the -choicegroups dict, it is not necessary to specify them - in the -choices list. It is effectively a simpler form of - specifying choices when no grouping is required. It is fine to - use both -choices and -choicegroups e.g specifying all in -choices - and then including only some that need grouping in -choicegroups. - -choicelabels {} - keys are the values/argument names from -choices (or equivalently - members of value entries from the -choicegroups dict) - The values in the choicelabels dict are text values, possibly - containing newlines, that are displayed below each choice. - This is commonly a very basic summary of the choice. In the - case of a subcommand it may be a usage synopsis for further - arguments. - -choicerestricted - Whether values not specified in -choices or -choicegroups are - allowed. Defaults to true. - -choiceprefix - This specifies whether unique prefixes are able to be used - instead of the complete string. This is calculated using - tcl::prefix::match - and will display in the autogenerated - usage output. Defaults to true. - -choiceprefixdenylist {} - These choices should match exactly a choice entry in one of - the settings -choices or -choicegroups. - These will still be used in prefix calculation - but the full - choice argument must be entered to select the choice. - -choicegroups {} - Generally this would be used instead of -choices to allow - usage display of choices grouped by some name (or the empty - string for 'ungrouped' items which appear first). - See for example the output if 'i zlib' where choices of the - next subcommand are grouped by the names compression,channel, - streaming and checksumming. The -choices list is equivalent - to a -choicegroups dict entry where the key (groupname) is - the empty string. Both may be specified, in which case the - final list of available choices will be a union of the listed - values in -choices and the values from each choice group. - Choice values specified in -choices are effectively ungrouped - unless overridden by placing them in a choicegroup. - -choicemultiple (default {1 1}) - is a pair representing min and max number of choices - that can be present in the value. - If is a single integer it is equivalent to a - specified with the same integer for both min and max. - Max of -1 represents no upper limit. - If allows more than one choice the value is a list - consisting of items in the choices made available through - entries in -choices/-choicegroups. - -minsize (type dependant) - -maxsize (type dependant) - -range (type dependant) - - - " - -dynamic -type boolean -default 0 -help\ - "If -dynamic is true, tstr interpolations of the form \$\{\$var\} - are re-evaluated on each call. - If the definition is being used not just as documentation, but is also - used within the function to parse args, e.g using punk::args::get_by_id, - then it should be noted that there is a slight performance penalty for the - dynamic case. - It is often not significant, perhaps depending on what vars/commands are - used but -dynamic true might be less desirable if the command is used in - inner loops in more performance-sensitive code. - " - @values -min 1 -max -1 - text -type string -multiple 1 -help\ - "Block(s) of text representing the argument definition for a command. - At least one must be supplied. If multiple, they are joined together with \\n. - Using multiple text arguments may be useful to mix curly-braced and double-quoted - strings to have finer control over interpolation when defining arguments. - (this can also be handy for sections that pull resolved definition lines - from existing definitions (by id) for re-use of argument specifications and help text) - - e.g the following definition passes 2 blocks as text arguments - definition { - @id -id ::myns::myfunc - @cmd -name myns::myfunc -help\\ - \"Description of command\" - - #The following option defines an option-value pair - -option1 -default blah -type string - #The following option defines a flag style option (solo) - -flag1 -default 0 -type none -help\\ - \"Info about flag1 - subsequent help lines auto-dedented by whitespace to left - of corresponding record start (in this case -flag1) - + first 4 spaces if they are all present. - This line has no extra indent relative to first line 'Info about flag1' - This line indented a further 6 chars\" - - @values -min 1 -max -1 - #Items that don't begin with * or - are value definitions - v1 -type integer -default 0 - thinglist -type string -multiple 1 - } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" - " - }]] - - proc New_command_form {name} { - #probably faster to inline a literal dict create in the proc than to use a namespace variable - set leaderspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - -ensembleparameter 0\ - ] - set optspec_defaults [tcl::dict::create\ - -type string\ - -optional 1\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - -prefix 1\ - ] - set valspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - - #form record can have running entries such as 'argspace' that aren't given to arg parser - #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict - return [dict create\ - argspace "leaders"\ - ARG_INFO [tcl::dict::create]\ - ARG_CHECKS [tcl::dict::create]\ - LEADER_DEFAULTS [tcl::dict::create]\ - LEADER_REQUIRED [list]\ - LEADER_NAMES [list]\ - LEADER_MIN ""\ - LEADER_MAX ""\ - LEADERSPEC_DEFAULTS $leaderspec_defaults\ - LEADER_CHECKS_DEFAULTS {}\ - OPT_DEFAULTS [tcl::dict::create]\ - OPT_REQUIRED [list]\ - OPT_NAMES [list]\ - OPT_ANY 0\ - OPT_SOLOS {}\ - OPTSPEC_DEFAULTS $optspec_defaults\ - OPT_CHECKS_DEFAULTS {}\ - VAL_DEFAULTS [tcl::dict::create]\ - VAL_REQUIRED [list]\ - VAL_NAMES [list]\ - VAL_MIN ""\ - VAL_MAX ""\ - VALSPEC_DEFAULTS $valspec_defaults\ - VAL_CHECKS_DEFAULTS {}\ - FORMDISPLAY [tcl::dict::create]\ - ] - - } - - proc errorstyle {args} { - #set or query the running config -errorstyle - #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? - #values: - #debug, enhanced, standard, basic, minimal - error todo - } - proc define {args} { - variable rawdef_cache - variable id_cache_rawdef - variable argdata_cache - if {[dict exists $rawdef_cache $args]} { - return [dict get [dict get $rawdef_cache $args] -id] - } else { - set id [rawdef_id $args] - if {[id_exists $id]} { - #we seem to be re-creating a previously defined id... - #clear any existing caches for this id - puts stderr "punk::args::define Redefinition of id:$id - clearing existing data" - - #dict unset argdata_cache $prevraw ;#silently does nothing if key not present - dict for {k v} $argdata_cache { - if {[dict get $v id] eq $id} { - dict unset argdata_cache $k - } - } - dict for {k v} $rawdef_cache { - if {[dict get $v -id] eq $id} { - dict unset rawdef_cache $k - } - } - dict unset id_cache_rawdef $id - } - set is_dynamic [rawdef_is_dynamic $args] - set defspace [uplevel 1 {::namespace current}] - dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic -defspace $defspace] - dict set id_cache_rawdef $id $args - return $id - } - } - - proc idquery_info {id} { - variable id_cache_rawdef - variable rawdef_cache - if {[dict exists $id_cache_rawdef $id]} { - set sep [string repeat - 40] - set rawdef [dict get $id_cache_rawdef $id] - if {[dict exists $rawdef_cache $rawdef]} { - set idinfo [dict get $rawdef_cache $rawdef] - } else { - set idinfo "" - } - set result "raw definition:" - append result \n $sep - append result \n $rawdef - append result \n $sep - append result \n "id info:" - append result \n $idinfo - append result \n $sep - variable argdata_cache - #lsearch -stride not avail (or buggy) in some 8.6 interps - search manually for now (2025). todo - modernize some time after Tcl 9.0/9.1 more widespread.(2027?) - #check for and report if id is present multiple times - set argdata_records [list] - dict for {k v} $argdata_cache { - if {[dict get $v id] eq $id} { - if {$k eq $rawdef} { - lappend argdata_records [list 1 $k $v] - } else { - lappend argdata_records [list 0 $k $v] - } - } - } - append result \n "argdata cache:" - if {![llength $argdata_records]} { - append result \n "(not present)" - } else { - append result \n "present [llength $argdata_records] time(s)" - foreach r $argdata_records { - lassign $r match k v - if {$match} { - append result \n " - present with same rawdef key" - } else { - append result \n " - present with different rawdef key" - append result \n " [punk::lib::indent $k { }]" - } - } - if {[llength $argdata_records] > 1} { - append result \n "*more than one record was not expected - review*" - } - } - append result \n $sep - return $result - } - } - - proc define2 {args} { - dict get [resolve {*}$args] id - } - - proc resolve {args} { - variable rawdef_cache - variable id_cache_rawdef - set defspace "" - if {[dict exists $rawdef_cache $args]} { - set cinfo [dict get $rawdef_cache $args] - set id [dict get $cinfo -id] - set is_dynamic [dict get $cinfo -dynamic] - if {[dict exists $cinfo -defspace]} { - set defspace [dict get $cinfo -defspace] - } - } else { - #should we really be resolving something that hasn't been defined? - set id [rawdef_id $args] - puts stderr "Warning: punk::args::resolve called with undefined id:$id" - set is_dynamic [rawdef_is_dynamic $args] - dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] - dict set id_cache_rawdef $id $args - } - - - variable argdata_cache - variable argdefcache_unresolved - - - set cache_key $args - #ideally we would use a fast hash algorithm to produce a short key with low collision probability. - #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) - #review - check if there is a built-into-tcl way to do this quickly - #for now we will just key using the whole string - #performance seems ok - memory usage probably not ideal - #quote from DKF 2021 - #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. - #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. - #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. - #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). - #> If dealing with very large amounts of data, using a database is probably a good plan. - - set textargs $args - if {![llength $args]} { - punk::args::get_by_id ::punk::args::define {} - return - } - #if {[lindex $args 0] eq "-dynamic"} { - # set is_dynamic [lindex $args 1] - # set textargs [lrange $args 2 end] - #} - - #experimental - set LVL 2 - - if {!$is_dynamic} { - if {[tcl::dict::exists $argdata_cache $cache_key]} { - return [tcl::dict::get $argdata_cache $cache_key] - } - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - if {[string first \$\{ $optionspecs] > 0} { - if {$defspace ne ""} { - #normal/desired case - set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } else { - #todo - deprecate/stop from happening? - puts stderr "punk::args::resolve calling tstr for id:$id with no known definition space (-defspace empty)" - set optionspecs [uplevel $LVL [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } - } - } else { - - if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { - set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel $LVL [list ::subst $param]] - } - } else { - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - #dynamic - double substitution required. - #e.g - # set DYN_CHOICES {${[::somewhere::get_choice_list]}} - # set RED [punk::ansi::a+ bold red] - # set RST [punk::ansi::a] - # punk::args::define { - # -arg -choices {${$DYN_CHOICES}} -help "${$RED}important info${$RST}" - #} - if {$defspace ne ""} { - set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } - #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) - if {[string first \$\{ $optionspecs] > 0} { - set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel $LVL [list ::subst $param]] - } - tcl::dict::set argdefcache_unresolved $cache_key $pt_params - } - } - #argdata_cache should be limited in some fashion or will be a big memory leak??? - if {[tcl::dict::exists $argdata_cache $optionspecs]} { - #resolved cache version exists - return [tcl::dict::get $argdata_cache $optionspecs] - } - } - - - - #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices - #default to 1 for convenience - - #checks with no default - #-minsize -maxsize -range - - - #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi - #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist - - #set opt_defaults [tcl::dict::create] - #set val_defaults [tcl::dict::create] - - #set opt_solos [list] - #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end - - set records [list] - set linebuild "" - - set linelist [split $optionspecs \n] - set lastindent "" - foreach ln $linelist { - if {[tcl::string::trim $ln] eq ""} {continue} - regexp {(\s*).*} $ln _all lastindent - break ;#break at first non-empty - } - #puts "indent1:[ansistring VIEW $lastindent]" - set in_record 0 - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - foreach rawline $linelist { - set recordsofar [tcl::string::cat $linebuild $rawline] - #ansi colours can stop info complete from working (contain square brackets) - #review - when exactly are ansi codes allowed/expected in record lines. - # - we might reasonably expect them in default values or choices or help strings - # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. - # - eg set line "set x \"a[a+ red]red[a]\"" - # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket - if {$has_punkansi} { - set test_complete [punk::ansi::ansistrip $recordsofar] - } else { - #review - #we only need to strip enough to stop interference with 'info complete' - set test_complete [string map [list \x1b\[ ""] $recordsofar] - } - if {![tcl::info::complete $test_complete]} { - #append linebuild [string trimleft $rawline] \n - if {$in_record} { - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. - #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. - #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. - #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) - #(note string first "" $str is fast and returns -1) - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline \n - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline \n - } else { - append linebuild $rawline \n - } - } else { - set in_record 1 - regexp {(\s*).*} $rawline _all lastindent - #puts "indent: [ansistring VIEW -lf 1 $lastindent]" - #puts "indent from rawline:$rawline " - append linebuild $rawline \n - } - } else { - set in_record 0 - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline - } else { - append linebuild $rawline - } - lappend records $linebuild - set linebuild "" - } - } - set cmd_info {} - set package_info {} - set id_info {} ;#e.g -children ?? - set doc_info {} - #set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table - set seealso_info {} - set keywords_info {} - ###set leader_min 0 - ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit - #set leader_max "" - #(common case of no leaders specified) - #set opt_any 0 - #set val_min 0 - #set val_max -1 ;#-1 for no limit - set DEF_definition_id $id - - #form_defs - set F [dict create _default [New_command_form _default]] - set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under - - #set ARGSPACE [dict create] ;#keyed on form - #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values - - set refs [dict create] - set record_type "" - set record_number -1 ;# - foreach rec $records { - set trimrec [tcl::string::trim $rec] - switch -- [tcl::string::index $trimrec 0] { - "" - # {continue} - } - incr record_number - set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict - if {[llength $record_values] % 2 != 0} { - #todo - avoid raising an error - store invalid defs keyed on id - error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" - } - # ---------------------------------------------------------- - # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. - #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! - #(form_ids_active is otherwise set in the @form handling block) - - #consider the following 2 line entry which is potentially dynamically included via a tstr: - # @form -form {* newform} - # @form -form {newform} -synopsis "cmd help ?stuff?" - #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. - #(because _default is usually 'taken over' by the first encountered form id) - #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record - #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. - - if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { - set patterns [dict get $record_values -form] - set record_form_ids [list] - foreach p $patterns { - if {[regexp {[*?\[\]]} $p]} { - #isglob - only used for matching existing forms - lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] - } else { - #don't test for existence - will define new form if necessary - lappend record_form_ids $p - } - } - #-form values could be globs that didn't match. record_form_ids could be empty.. - if {[llength $record_form_ids]} { - #only rename _default if it's the sole entry - if {[dict size $F] == 1 && [dict exists $F "_default"]} { - if {"_default" ni $record_form_ids} { - #only initial form exists - but we are mentioning new ones - #first rename the _default to first encountered new form id - #(just replace whole dict with new key - same data) - set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] - #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F - #we are only setting active because of the rename - @form is the way to change active forms list - set form_ids_active [lindex $record_form_ids 0] - } - } - foreach fid $record_form_ids { - if {![dict exists $F $fid]} { - if {$firstword eq "@form"} { - #only @form directly supplies keys - dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] - } else { - dict set F $fid [New_command_form $fid] - } - } else { - #update form with current record opts, except -form - if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } - } - } - } - } else { - #missing or empty -form - set record_form_ids $form_ids_active - if {$firstword eq "@form"} { - foreach fid $form_ids_active { - dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] - } - } - } - # ---------------------------------------------------------- - - set firstchar [tcl::string::index $firstword 0] - set secondchar [tcl::string::index $firstword 1] - if {$firstchar eq "@" && $secondchar ne "@"} { - set record_type "directive" - set directive_name $firstword - set at_specs $record_values - - switch -- [tcl::string::range $directive_name 1 end] { - dynamic { - set is_dynamic 1 - } - id { - #disallow duplicate @id line ? - #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) - - #id An id will be allocated if no id line present or the -id value is "auto" - - if {[dict exists $at_specs -id]} { - set thisid [dict get $at_specs -id] - if {$thisid ni [list $id auto]} { - error "punk::args::define @id mismatch existing: $id vs $thisid" - } - } - set id_info $at_specs - } - ref { - #a reference within the definition - #e.g see punk::args::tclcore ::after - #global reference dict - independent of forms - #ignore refs without an -id - #store all keys except -id - #complete overwrite if refid repeated later on - if {[dict exists $at_specs -id]} { - dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] - } - } - default { - #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple - #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) - #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) - #That is possibly too complicated and/or unnecessary? - #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? - - if {[dict exists $at_specs -id]} { - set copyfrom [get_spec [dict get $at_specs -id]] - #we don't copy the @id info from the source - #for now we only copy across if nothing set.. - #todo - bring across defaults for empty keys at targets? - #need to keep it simple enough to reason about behaviour easily.. - if {[dict size $copyfrom]} { - if {![dict size $cmd_info]} { - set cmd_info [dict get $copyfrom cmd_info] - } - if {![dict size $doc_info]} { - set doc_info [dict get $copyfrom doc_info] - } - - #foreach fid $record_form_ids { - # #only use elements with matching form id? - # #probably this feature mainly useful for _default anyway so that should be ok - # #cooperative doc sets specified in same file could share via known form ids too - # FORMDISPLAY has keys -header -body - # if {![dict size $F $fid $FORMDISPLAY]} { - # if {[dict exists $copyfrom FORMS $fid FORMDISPLAY]} { - # dict set F $fid FORMDISPLAY [dict get $copyfrom FORMS $fid FORMDISPLAY] - # } - # } - # #TODO - # #create leaders opts vals depending on position of @default line? - # #options on @default line to exclude/include sets??? - #} - } - } - } - form { - # arity system ? - #handle multiple parsing styles based on arities and keyword positions (and/or flags?) - #e.g see lseq manual with 3 different parsing styles. - #aim to produce a table/subtable for each - # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ - # -arities { - # 2 - # {3 anykeys {1 .. 1 to}} - # {4 anykeys {3 by}} - # {5 anykeys {1 .. 1 to 3 by}} - # }\ - # -fallback 1 - # ... - # @parser -synopsis "start 'count' count ??'by'? step?"\ - # -arities { - # {3 anykeys {1 count}} - # } - # ... - # @form -synopsis "count ?'by' step?"\ - # -arities { - # 1 - # {3 anykeys {1 by}} - # } - # - # see also after manual - # @form -arities {1} - # @form -arities { - # 1 anykeys {0 info} - # } - #todo - - #can we generate a form synopsis if -synopsis not supplied? - - #form id can be list of ints|names?, or * - if {[dict exists $at_specs -form]} { - set idlist [dict get $at_specs -form] - if {$idlist eq "*"} { - #* only applies to form ids that exist at the time - set idlist [dict keys $F] - } - set form_ids_active $idlist - } - #new form keys already created if they were needed (done for all records that have -form ) - } - package { - set package_info [dict merge $package_info $at_specs] - } - cmd { - #allow arbitrary - review - set cmd_info [dict merge $cmd_info $at_specs] - } - doc { - set doc_info [dict merge $doc_info $at_specs] - } - formdisplay { - #override the displayed argument table for the form. - #(formdisplay keys -header -body) - #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing - foreach fid $record_form_ids { - tcl::dict::set F $fid FORMDISPLAY [dict merge [tcl::dict::get $F $fid FORMDISPLAY] $at_specs] - } - } - opts { - foreach fid $record_form_ids { - if {[tcl::dict::get $F $fid argspace] eq "values"} { - error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" - } - tcl::dict::set F $fid argspace "options" - set tmp_optspec_defaults [dict get $F $fid OPTSPEC_DEFAULTS] - - foreach {k v} $at_specs { - switch -- $k { - -form { - #review - handled above - } - -any - - -anyopts { - #set opt_any $v - tcl::dict::set F $fid OPT_ANY $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { - #review - only apply to certain types? - tcl::dict::set tmp_optspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_optspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - index { - set v indexexpression - } - none - "" - - - any - ansistring - globstring - list { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_optspec_defaults -type $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple - - -prefix { - #allow overriding of defaults for options that occur later - tcl::dict::set tmp_optspec_defaults $k $v - } - default { - set known { -any -form -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" - } - } - } - tcl::dict::set F $fid OPTSPEC_DEFAULTS $tmp_optspec_defaults - } ;# end foreach record_form_ids - } - leaders { - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] in [list options values]} { - error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" - } - set tmp_leaderspec_defaults [dict get $F $fid LEADERSPEC_DEFAULTS] - - foreach {k v} $at_specs { - switch -- $k { - -form { - #review - handled above - } - -min - - -minvalues { - if {$v < 0} { - error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MIN $v - #if {$leader_max == 0} { - # set leader_max -1 - #} - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MAX $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -choiceinfo { - if {[llength $v] %2 != 0} { - error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - #-choicegroups? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_leaderspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - index { - set v indexexpression - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -ensembleparameter { - #review - tcl::dict::set tmp_leaderspec_defaults $k $v - #error "punk::args::define - -ensembleparameter not supported as a default for @leaders - only valid on actual leader arguments" - } - default { - set known { -min -form -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid LEADERSPEC_DEFAULTS $tmp_leaderspec_defaults - - } ;#end foreach record_form_ids - - } - values { - foreach fid $record_form_ids { - dict set F $fid argspace "values" - - set tmp_valspec_defaults [dict get $F $fid VALSPEC_DEFAULTS] - - foreach {k v} $at_specs { - switch -- $k { - -form { - #review - handled above - } - -min - - -minvalues { - if {$v < 0} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" - } - #set val_min $v - dict set F $fid VAL_MIN $v - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" - } - #set val_max $v - dict set F $fid VAL_MAX $v - } - -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_valspec_defaults $k $v - } - -choiceinfo - -choicegroups { - if {[llength $v] % 2 != 0} { - error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - # -choicegroups ?? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_valspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - index { - set v indexexpression - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set tmp_valspec_defaults $k $v - } - default { - set known { -min -form -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid VALSPEC_DEFAULTS $tmp_valspec_defaults - } - - } - seealso { - #todo! - #like @doc, except displays in footer, multiple - sub-table? - set seealso_info [dict merge $seealso_info $at_specs] - } - keywords { - #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? - set keywords_info [dict merge $keywords_info $at_specs] - } - default { - error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @formdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" - } - } - #record_type directive - continue - } elseif {$firstchar eq "-"} { - set argname $firstword - set argdef_values $record_values - tcl::dict::set argdef_values -ARGTYPE option - - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - dict set F $fid argspace "options" - } elseif {[dict get $F $fid argspace] eq "values"} { - error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" - } - set record_type option - dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] - #lappend opt_names $argname - } - - set is_opt 1 - } else { - set argname $firstword - if {$firstchar eq "@"} { - #allow basic @@ escaping for literal argname that begins with @ - set argname [tcl::string::range $argname 1 end] - } - - set argdef_values $record_values - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - set record_type leader - tcl::dict::set argdef_values -ARGTYPE leader - #lappend leader_names $argname - set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] - if {$argname ni $temp_leadernames} { - lappend temp_leadernames $argname - tcl::dict::set F $fid LEADER_NAMES $temp_leadernames - } else { - #This can happen if the definition has repeated values - error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" - } - - if {[dict get $F $fid LEADER_MAX] >= 0} { - if {[dict get $F $fid LEADER_MAX] < [llength $temp_leadernames]} { - puts stderr "punk::args::resolve warning arg $argname LEADER_MAX == [dict get $F $fid LEADER_MAX] but [llength $temp_leadernames] leader names found @id:$DEF_definition_id" - dict set F $fid LEADER_MAX [llength $temp_leadernames] - } - } - } else { - set record_type value - tcl::dict::set argdef_values -ARGTYPE value - set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] - if {$argname ni $temp_valnames} { - lappend temp_valnames $argname - tcl::dict::set F $fid VAL_NAMES $temp_valnames - } else { - error "punk::args::define - arg $argname already present as value in '$rec' (command form:'$fid') @id:$DEF_definition_id" - } - #lappend val_names $argname - if {[dict get $F $fid VAL_MAX] >= 0} { - if {[dict get $F $fid VAL_MAX] < [llength $temp_valnames]} { - puts stderr "punk::args::resolve warning arg $argname VAL_MAX == [dict get $F $fid VAL_MAX] but [llength $temp_valnames] value names found @id:$DEF_definition_id" - dict set F $fid VAL_MAX [llength $temp_valnames] - } - } - } - } - - set is_opt 0 - } - - - #assert - we only get here if it is a value or flag specification line. - #assert argdef_values has been set to the value of record_values - - foreach fid $record_form_ids { - if {$is_opt} { - set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS] - } else { - if {[dict get $F $fid argspace] eq "values"} { - set spec_merged [dict get $F $fid VALSPEC_DEFAULTS] - } else { - set spec_merged [dict get $F $fid LEADERSPEC_DEFAULTS] - } - } - - # -> argopt argval - foreach {spec specval} $argdef_values { - #literal-key switch - bytecompiled to jumpTable - switch -- $spec { - -form { - - } - -type { - #normalize here so we don't have to test during actual args parsing in main function - switch -- [tcl::string::tolower $specval] { - int - integer { - tcl::dict::set spec_merged -type int - } - bool - boolean { - tcl::dict::set spec_merged -type bool - } - char - character { - tcl::dict::set spec_merged -type char - } - dict - dictionary { - tcl::dict::set spec_merged -type dict - } - index - indexexpression { - tcl::dict::set spec_merged -type indexexpression - } - "" - none { - if {$is_opt} { - tcl::dict::set spec_merged -type none - 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. - } - } else { - #-solo only valid for flags - error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" - } - } - any - anything { - tcl::dict::set spec_merged -type any - } - ansi - ansistring { - tcl::dict::set spec_merged -type ansistring - } - any - string - globstring { - tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - } - literal { - #value is the name of the argument - if {$is_opt} { - error "punk::args::define - invalid -type 'literal' for flag argument '$argname' @id:$DEF_definition_id" - } - tcl::dict::set spec_merged -type literal - } - default { - #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW - tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - } - } - } - -default - -solo - -range - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo - - -minsize - -maxsize - -nocase - -optional - -multiple - - -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - - -regexprepass - -regexprefail - -regexprefailmsg - { - #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines - #review -solo 1 vs -type none ? conflicting values? - tcl::dict::set spec_merged $spec $specval - } - -ensembleparameter { - #review - only leaders? - tcl::dict::set spec_merged $spec $specval - } - -prefix { - #for flags/options - tcl::dict::set spec_merged $spec $specval - } - -validationtransform { - #string is dict only 8.7/9+ - if {[llength $specval] % 2} { - error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" - } - dict for {tk tv} $specval { - switch -- $tk { - -function - -type - -minsize - -maxsize - -range { - } - default { - set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? - error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" - } - } - } - - } - default { - if {[string match ref-* $spec]} { - #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) - #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. - if {![tcl::dict::exists $refs $specval]} { - puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" - } else { - set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" - if {$targetswitch eq "-*"} { - set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id - } else { - if {[tcl::dict::exists $refs $specval $targetswitch]} { - tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] - } else { - puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" - } - } - } - } else { - set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - -ensembleparameter\ - ] - error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" - } - } - } - } ;# end foreach {spec specval} argdef_values - - - if {$is_opt} { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - if {[tcl::dict::get $spec_merged -type] eq "none"} { - #JJJJ - dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname] - } - } else { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - tcl::dict::set F $fid ARG_INFO $argname $spec_merged - #review existence of -default overriding -optional - if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { - if {$is_opt} { - set temp_opt_required [dict get $F $fid OPT_REQUIRED] - lappend temp_opt_required $argname - dict set F $fid OPT_REQUIRED $temp_opt_required - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - set temp_leader_required [dict get $F $fid LEADER_REQUIRED] - lappend temp_leader_required $argname - dict set F $fid LEADER_REQUIRED $temp_leader_required - } else { - set temp_val_required [dict get $F $fid VAL_REQUIRED] - lappend temp_val_required $argname - dict set F $fid VAL_REQUIRED $temp_val_required - } - } - } - if {[tcl::dict::exists $spec_merged -default]} { - if {$is_opt} { - #tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] - tcl::dict::set F $fid OPT_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } else { - #tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] - tcl::dict::set F $fid VAL_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } - } - } - } ;# end foreach fid record_form_ids - - } ;# end foreach rec $records - - - #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { - # variable id_counter - # set DEF_definition_id "autoid_[incr id_counter]" - #} - - - #now cycle through ALL forms not just form_ids_active (record_form_ids) - dict for {fid formdata} $F { - # REVIEW - #no values specified - we can allow last leader to be multiple - foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { - error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" - } - } - - #todo - disallow any -multiple == true entries if any leaders have -multiple == true? - #(creates parsing ambiguity) - #ambiguity could be resolved if at least one required option/flag eg -- - #ambiguities could theoretically also be resolved with required literals or choices - or even based on argument type - #(overcomplex? todo see if any core/tcllib commands work like that) - - #only allow a single entry within VAL_NAMES to have -multiple == true - #example of command with non-trailing -multiple == true is core command: 'file copy ?-force? ?--? source ?source?... targetDir - set val_multiples 0 - foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { - if {$val_multiples > 0} { - error "bad setting -multiple true on argument spec for value '$valname' in command form:'$fid'. Only a single value argument specification can be marked with -multiple true @id:$DEF_definition_id" - } - incr val_multiples - } - } - - #todo - document that ambiguities in API are likely if both @leaders and @values used - #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) - - - dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata LEADERSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata OPTSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata VALSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - - - - - #todo - precalculate a set of 'arity' entries for each form - #We want a structure for the arg parser to get easy access and make a fast decision on which form applies - #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? - #1) after ms (1 1) - #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? - #3) after cancel id (2 2) - #4) after cancel script ?script...? (2 -1) - #5) after idle script ?script...? (1 -1) - #6) after info ?id? (1 2) - - #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) - - #in the above case we have no unique total_arity - #we would also want to consider values when selecting - #e.g given the invalid command "after cancel" - # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. - - - - set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands - #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use - #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form - #e.g commandline completion could show list of synopsis entries to select from - - set form_info [dict create] - dict for {fid fdict} $F { - dict set form_info $fid {} - dict for {optk optv} $fdict { - if {[string match -* $optk]} { - dict set form_info $fid $optk $optv - } - } - } - - set argdata_dict [tcl::dict::create\ - id $DEF_definition_id\ - cmd_info $cmd_info\ - doc_info $doc_info\ - package_info $package_info\ - seealso_info $seealso_info\ - id_info $id_info\ - FORMS $F\ - form_names [dict keys $F]\ - form_info $form_info\ - ] - - tcl::dict::set argdata_cache $cache_key $argdata_dict - if {$is_dynamic} { - #also cache resolved version - tcl::dict::set argdata_cache $optionspecs $argdata_dict - } - - #tcl::dict::set id_cache_rawdef $DEF_definition_id $args - #puts "xxx:$result" - return $argdata_dict - } - - #return raw definition list as created with 'define' - # - possibly with unresolved dynamic parts - proc raw_def {id} { - variable id_cache_rawdef - set realid [real_id $id] - if {![dict exists $id_cache_rawdef $realid]} { - return "" - } - return [tcl::dict::get $id_cache_rawdef $realid] - } - - - namespace eval argdoc { - variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @formdisplay @seealso @leaders @opts @values leaders opts values} - variable resolved_def_TYPE_CHOICEGROUPS { - directives {@id @package @cmd @ref @doc @formdisplay @seealso} - argumenttypes {leaders opts values} - remaining_defaults {@leaders @opts @values} - } - - lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { - @id -id ::punk::args::resolved_def - @cmd -name punk::args::resolved_def -help\ - "Resolves or retrieves the previously resolved definition and - uses the 'spec' form to build a response in definition format. - - Pulling argument definition data from another function is a form - of tight coupling to the other function that should be done with - care. - - Note that the directives @leaders @opts @values may appear multiple - times in a source definition - applying defaults for arguments that - follow. When retrieving these - there is only a single result for - each that represents the defaults after all have been applied. - When retrieving -types * each of these will be positioned before - the arguments of that type - but this doesn't mean there was a single - leading directive for this argument type in the source definition. - Each argument has already had its complete specification recorded in - its own result. - - When manually specifying -types, the order @leaders then @opts then - @values must be maintained - but if they are placed before their - corresponding arguments, they will not affect the retrieved arguments - as these arguments are already fully spec'd. The defaults from the - source can be removed by adding @leaders, @opts @values to the - -antiglobs list, but again - this won't affect the existing arguments. - Each argument can have members of its spec overridden using the - -override dictionary. - " - @leaders -min 0 -max 0 - @opts - -return -default text -choices {text dict} - -form -default 0 -help\ - "Ordinal index or name of command form" - - #no restriction on number of types/repetitions? - -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} - -antiglobs -default {} -type list -help\ - "Glob patterns for directive or argument/flags to - be suppressed" - -override -type dict -optional 1 -default "" -help\ - "dict of dicts. Key in outer dict is the name of a - directive or an argument. Inner dict is a map of - overrides/additions (- ...) for that line. - " - @values -min 1 -max -1 - id -type string -help\ - "identifer for a punk::args definition - This will usually be a fully-qualifed - path for a command name" - pattern -type string -optional 1 -default * -multiple 1 -help\ - "glob-style patterns for retrieving value or switch - definitions. - - If -type is * and pattern is * the entire definition including - directive lines will be returned in line form. - (directives are lines beginning with - @ e.g @id, @cmd etc) - - if -type is leaders,opts or values matches from that type - will be returned. - - if -type is another directive such as @id, @doc etc the - patterns are ignored. - - " - }]] - } - - - proc resolved_def {args} { - #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. - set opts [dict create\ - -return text\ - -types {}\ - -form 0\ - -antiglobs {}\ - -override {}\ - ] - if {[llength $args] < 1} { - #must have at least id - punk::args::parse $args withid ::punk::args::resolved_def - return - } - set patterns [list] - - #a definition id must not begin with "-" ??? review - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {$a in {-type -types}} { - incr i - dict set opts -types [lindex $args $i] - } elseif {[string match -* $a]} { - incr i - dict set opts $a [lindex $args $i] - } else { - set id [lindex $args $i] - set patterns [lrange $args $i+1 end] - break - } - if {$i == [llength $args]-1} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - if {![llength $patterns]} { - set patterns [list *] - } - dict for {k v} $opts { - switch -- $k { - -return - -form - -types - -antiglobs - -override {} - default { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - } - set typelist [dict get $opts -types] - if {[llength $typelist] == 0} { - set typelist {*} - } - foreach type $typelist { - if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - - - variable id_cache_rawdef - set realid [real_id $id] - if {$realid eq ""} { - return - } - - set deflist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] - - set opt_form [dict get $opts -form] - if {[string is integer -strict $opt_form]} { - set formname [lindex [dict get $specdict form_names] $opt_form] - } else { - set formname $opt_form - } - set opt_override [dict get $opts -override] - set opt_return [dict get $opts -return] - - #set arg_info [dict get $specdict ARG_INFO] - set arg_info [dict get $specdict FORMS $formname ARG_INFO] - set argtypes [dict create leaders leader opts option values value] - - set opt_antiglobs [dict get $opts -antiglobs] - set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] - set suppressed_directives [list] - set suppressed_args [list] - foreach ag $opt_antiglobs { - foreach d $directives { - if {[string match $ag $d]} { - lappend suppressed_directives $d - } - } - foreach argname [dict keys $arg_info] { - if {[string match $ag $argname]} { - lappend suppressed_args $argname - } - } - } - set suppressed_directives [lsort -unique $suppressed_directives] - set suppressed_args [lsort -unique $suppressed_args] - - set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] - - set globbed [list] - foreach pat $patterns { - set matches [dict keys $arg_info $pat] - lappend globbed {*}$matches - } - set globbed [lsort -unique $globbed] - #maintain order of original arg_info keys in globbed results - set ordered_globbed [list] - foreach a [dict keys $arg_info] { - if {$a ni $ordered_globbed && $a in $globbed} { - lappend ordered_globbed $a - } - } - set included_args [punk::args::system::punklib_ldiff $ordered_globbed $suppressed_args] - - set result "" - set resultdict [dict create] - foreach type $typelist { - switch -exact -- $type { - * { - if {"@id" in $included_directives} { - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - foreach directive {@package @cmd @doc @seealso} { - set dshort [string range $directive 1 end] - if {"$directive" in $included_directives} { - if {[dict exists $opt_override $directive]} { - append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict ${dshort}_info]" - dict set resultdict $directive [dict get $specdict ${dshort}_info] - } - } - } - - #todo @formdisplay - - - #output ordered by leader, option, value - foreach pseudodirective {leaders opts values} tp {leader option value} { - set directive "@$pseudodirective" - switch -- $directive { - @leaders {set defaults_key LEADERSPEC_DEFAULTS} - @opts {set defaults_key OPTSPEC_DEFAULTS} - @values {set defaults_key VALSPEC_DEFAULTS} - } - - if {"$directive" in $included_directives} { - if {[dict exists $opt_override "$directive"]} { - append result \n "$directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict FORMS $formname $defaults_key]" - dict set resultdict $directive [dict get $specdict FORMS $formname $defaults_key] - } - } - - if {$pseudodirective in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq $tp} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "$m $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - - } - @id { - if {"@id" in $included_directives} { - #only a single id record can exist - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - } - @package - @cmd - @doc - @seealso { - if {"$type" in $included_directives} { - set tp [string range $type 1 end] ;# @package -> package - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict ${tp}_info]" - dict set resultdict $type [dict get $specdict ${tp}_info] - } - } - #todo @formdisplay - } - @leaders - @opts - @values { - #these are the active defaults for further arguments - if {"$type" in $included_directives} { - switch -- $type { - @leaders {set defaults_key LEADERSPEC_DEFAULTS} - @opts {set defaults_key OPTSPEC_DEFAULTS} - @values {set defaults_key VALSPEC_DEFAULTS} - } - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS]" - dict set resultdict $type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] - } - } - } - leaders - opts - values { - #pseudo-directives - if {$type in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "$m $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - default { - } - } - if {$opt_return eq "text"} { - return $result - } else { - return $resultdict - } - } - } - - proc resolved_def_values {id {patternlist *}} { - variable id_cache_rawdef - set realid [real_id $id] - if {$realid ne ""} { - set speclist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [resolve {*}$speclist] - set arg_info [dict get $specdict ARG_INFO] - set valnames [dict get $specdict VAL_NAMES] - set result "" - if {$patternlist eq "*"} { - foreach v $valnames { - set def [dict get $arg_info $v] - set def [dict remove $def -ARGTYPE] - append result \n "$v $def" - } - return $result - } else { - foreach pat $patternlist { - set matches [dict keys $arg_info $pat] - set matches [lsearch -all -inline -glob $valnames $pat] - foreach m $matches { - set def [dict get $arg_info $m] - set def [dict remove $def -ARGTYPE] - append result \n "$m $def" - } - } - return $result - } - } - } - #proc resolved_def_leaders ?? - #proc resolved_def_opts ?? - - proc get_spec {id} { - set rdef [raw_def $id] - if {$rdef eq ""} { - return - } - return [resolve {*}$rdef] - #if {[id_exists $id]} { - # return [resolve {*}[raw_def $id]] - #} - } - proc is_dynamic {id} { - variable id_cache_rawdef - variable rawdef_cache - set deflist [raw_def $id] - if {[dict exists $rawdef_cache $deflist -dynamic]} { - return [dict get $rawdef_cache $deflist -dynamic] - } - return [rawdef_is_dynamic $deflist] - #@dynamic only has meaning as 1st element of a def in the deflist - } - - #@id must be within first 4 lines of a block - or assign auto - #review - @dynamic block where -id not explicitly set? - disallow? - proc rawdef_id {rawdef} { - set id "" - foreach d $rawdef { - foreach ln [lrange [split $d \n] 0 4] { - if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { - if {$firstword eq "@id"} { - if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { - set id [dict get $rest -id] - break - } - } - } - } - if {$id ne ""} { - break - } - } - if {$id eq "" || [string tolower $id] eq "auto"} { - variable id_counter - set id "autoid_[incr id_counter]" - } - #puts "==>id: $id" - return $id - } - #test the rawdef for @dynamic directive - proc rawdef_is_dynamic {rawdef} { - #temporary - old way - set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] - if {$flagged_dynamic} { - return true - } - foreach d $rawdef { - if {[regexp {\s*(\S+)} $d _match firstword]} { - if {$firstword eq "@dynamic"} { - return true - } - } - } - return false - } - - variable aliases - set aliases [dict create] - - lappend PUNKARGS [list { - @id -id ::punk::args::get_ids - @cmd -name punk::args::get_ids -help\ - "return list of ids for argument definitions" - @values -min 0 -max 1 - match -default * -help\ - "exact id or glob pattern for ids" - }] - proc get_ids {{match *}} { - variable id_cache_rawdef - variable aliases - return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] - } - - #we don't automatically test for (autodef)$id - only direct ids and aliases - proc id_exists {id} { - variable aliases - if {[tcl::dict::exists $aliases $id]} { - return 1 - } - variable id_cache_rawdef - tcl::dict::exists $id_cache_rawdef $id - } - proc set_alias {alias id} { - variable aliases - dict set aliases $alias $id - } - proc unset_alias {alias} { - variable aliases - dict unset aliases $alias - } - proc get_alias {alias} { - variable aliases - if {[dict exists $aliases $alias]} { - return [tcl::dict::get $aliases $alias] - } - } - - proc real_id {id} { - variable id_cache_rawdef - variable aliases - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } else { - set check_updates [list [namespace qualifiers $id]] - #puts stderr "---->real_id '$id' update_definitions $check_updates" - if {![llength [update_definitions $check_updates]]} { - #nothing new loaded - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } else { - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } - } - } - - proc status {} { - upvar ::punk::args::register::NAMESPACES registered - upvar ::punk::args::register::loaded_packages loaded_packages - upvar ::punk::args::register::loaded_info loaded_info - upvar ::punk::args::register::scanned_packages scanned_packages - upvar ::punk::args::register::scanned_info scanned_info - set result "" - # [format %-${w0}s $idtail] - set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] - append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n - set width_c2 [string length "Scanned_ids"] - set width_c3 [string length "Scantime_us"] - set width_c4 [string length "Loaded_defs"] - set width_c5 [string length "Loadtime_us"] - set count_unloaded 0 - set count_loaded 0 - foreach ns $registered { - if {$ns in $scanned_packages} { - set ids [dict get $scanned_info $ns idcount] - set scan_us [dict get $scanned_info $ns time] - } else { - set ids "" - set scan_us "" - } - if {$ns in $loaded_packages} { - incr count_loaded - set ldefs [dict get $loaded_info $ns defcount] - set load_us [dict get $loaded_info $ns time] - } else { - incr count_unloaded - set ldefs "" - set load_us "" - } - append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n - } - append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" - return $result - } - - #scanned_packages (list) - #namespace_docpackages (dict) - proc update_definitions {{nslist *}} { - #puts "----> update_definitions '$nslist'" - if {[set gposn [lsearch $nslist {}]] >= 0} { - lset nslist $gposn :: - } - upvar ::punk::args::register::NAMESPACES registered ;#list - upvar ::punk::args::register::loaded_packages loaded_packages ;#list - upvar ::punk::args::register::loaded_info loaded_info ;#dict - upvar ::punk::args::register::scanned_packages scanned_packages ;#list - upvar ::punk::args::register::scanned_info scanned_info ;#dict - upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict - - - #puts stderr "-->update_definitions '$nslist'" - #needs to run quickly - especially when no package namespaces to be scanned for argdefs - #e.g - gets called for each subcommand of an ensemble (could be many) - # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. - #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. - # -- --- --- --- --- --- - # common-case fast-path - - if {[llength $loaded_packages] == [llength $registered]} { - #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. - #assert - if all are registered - then all have been scanned - return {} - } - # -- --- --- --- --- --- - - set unscanned [punklib_ldiff $registered $scanned_packages] - if {[llength $unscanned]} { - foreach pkgns $unscanned { - set idcount 0 - set ts_start [clock microseconds] - if {[info exists ${pkgns}::PUNKARGS]} { - set seen_documentedns [list] ;#seen per pkgns - foreach definitionlist [set ${pkgns}::PUNKARGS] { - #namespace eval $evalns [list punk::args::define {*}$definitionlist] - set id [rawdef_id $definitionlist] - if {[string match autoid_* $id]} { - puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" - puts stderr "definition:\n" - foreach d $definitionlist { - set out "" - foreach ln [split $d \n] { - append out " " $ln \n - } - puts $out - } - continue - } - #todo - detect duplicate ids (last will silently win.. should be reported somewhere) - incr idcount - set documentedns [namespace qualifiers $id] - if {$documentedns eq ""} {set documentedns ::} - if {$documentedns ni $seen_documentedns} { - #don't add own ns as a key in namespace_docpackages - if {$documentedns ne $pkgns} { - dict lappend namespace_docpackages $documentedns $pkgns - } - lappend seen_documentedns $documentedns - } - } - } - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - dict set scanned_info $pkgns [dict create time $diff idcount $idcount] - #we count it as scanned even if PUNKARGS didn't exist - #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) - lappend scanned_packages $pkgns - } - } - - - - if {"*" in $nslist} { - set needed [punklib_ldiff $registered $loaded_packages] - } else { - set needed [list] - foreach pkgns $nslist { - if {![string match ::* $pkgns]} { - puts stderr "warning: update_definitions received unqualified ns: $pkgns" - set pkgns ::$pkgns - } - if {$pkgns in $registered && $pkgns ni $loaded_packages} { - lappend needed $pkgns - } - #argdoc sub namespace is a standard place to put defs that match the namespace below - #(generally the PUNKARGS in a namespace should apply to own ns) - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { - lappend needed $docns - } - } - if {[dict exists $namespace_docpackages $pkgns]} { - #this namespace has other argdef sources - foreach docns [dict get $namespace_docpackages $pkgns] { - if {$docns ni $loaded_packages} { - lappend needed $docns - } - } - } - } - } - - - - set newloaded [list] - foreach pkgns $needed { - #puts stderr "update_definitions Loading: $pkgns" - set ts_start [clock microseconds] - set def_count 0 - if {![catch { - if {[info exists ${pkgns}::PUNKARGS]} { - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - namespace eval ${pkgns}::argdoc { - set epath [namespace path] - set pkgns [namespace parent] - if {$pkgns ni $epath} { - namespace path [list {*}$epath $pkgns] ;#add to tail - } - - } - set evalns $docns - } else { - set evalns $pkgns - } - foreach definitionlist [set ${pkgns}::PUNKARGS] { - namespace eval $evalns [list punk::args::define {*}$definitionlist] - incr def_count - } - } - - #process list of 2-element lists - if {[info exists ${pkgns}::PUNKARGS_aliases]} { - foreach adef [set ${pkgns}::PUNKARGS_aliases] { - punk::args::set_alias {*}$adef - } - } - } errMsg]} { - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - lappend loaded_packages $pkgns - lappend newloaded $pkgns - dict set loaded_info $pkgns [dict create time $diff defcount $def_count] - } else { - puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" - } - } - return $newloaded - } - - #for use within get_dict only - #This mechanism gets less-than-useful results for oo methods - #e.g {$obj} - proc Get_caller {} { - #set call_level -3 ;#for get_dict call - set call_level -4 - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - #puts "-->$cmdinfo" - #puts "-->[tcl::info::frame -3]" - while {[string last \n $cmdinfo] >= 1} { - #looks like a script - haven't gone up far enough? - #(e.g patternpunk oo system: >punk . poses -invalidoption) - incr call_level -1 - if {[catch { - set nextup [tcl::info::frame $call_level] - } ]} { - break - } - set cmdinfo [tcl::dict::get $nextup cmd] - set caller [regexp -inline {\S+} $cmdinfo] - if {[interp alias {} $caller] ne ""} { - #puts "found alias for caller $caller to [interp alias {} $caller]" - #see if we can go further - incr call_level -1 - if {[catch { - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - } errM ]} { - puts "err: $errM" - break - } - } - } - set caller [regexp -inline {\S+} $cmdinfo] - if {$caller eq "namespace"} { - # review - message? - set cmdinfo "Get_caller (punk::args::get_dict?) called from namespace" - } - return $cmdinfo - } - - - # -------------------------------------- - #test of Get_caller - lappend PUNKARGS [list { - @id -id ::punk::args::test1 - @values -min 0 -max 0 - }] - proc test_get_dict {args} { - punk::args::get_dict [punk::args::raw_def ::punk::args::test1] $args - } - proc test_get_by_id {args} { - punk::args::get_by_id ::punk::args::test1 $args - } - #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. - proc test_callers {args} { - if {![llength $args]} { - puts "these test functions accept no arguments" - puts "Call with arg(s) to compare error output" - } - - if {[catch {test_get_dict {*}$args} errM]} { - puts $errM - } - puts "------------" - if {[catch {test_get_by_id {*}$args} errM]} { - puts $errM - } - return done - } - # -------------------------------------- - - set map "" - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::arg_error - @cmd -name punk::args::arg_error -help\ - "Generates a table (by default) of usage information for a command. - A trie system is used to create highlighted prefixes for command - switches and for subcommands or argument/switch values that accept - a defined set of choices. These prefixes match the mechanism used - to validate arguments (based on tcl::prefix::match). - - This function is called during the argument parsing process - (if the definition is not only being used for documentation) - It is also called by punk::args::usage which is in turn - called by the punk::ns introspection facilities which creates - on the fly definitions for some commands such as ensembles and - oo objects where a manually defined one isn't present. - " - @leaders -min 2 -max 2 - msg -type string -help\ - "Error message to display immediately prior to usage table. - May be empty string to just display usage. - " - spec_dict -type dict -help\ - "Dictionary of argument specifications. - This is the internal format parsed from - the textual definition. It contains the data - organised/optimised to allow the final arg - parser/validator to make decisions. - " - @opts - -badarg -type string -help\ - "name of an argument to highlight" - -parsedargs -type dict -help\ - "Result of successful punk::pargs::parse - (currently only looks at 'received')" - -aserror -type boolean -help\ - "If true, the usage table is raised as an error message, - otherwise it is returned as a value." - -return -choices {string table tableobject} -choicelabels { - string "no table layout" - tableobject "table object cmd" - table "full table layout" - } - -scheme -default error -choices {nocolour info error} - -form -default 0 -help\ - "Ordinal index or name of command form" - }] ] - - #basic recursion blocker - variable arg_error_isrunning 0 - proc arg_error {msg spec_dict args} { - #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. - #accept an option here so that we can still use full output for usage requests. - #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args - #Development/experimentation may be done with full table-based error reporting - but for production release it - #may be desirable to reduce overhead on catches. - #consider per-namespace or namespace-tree configurability. - #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due - #to resource availability etc - so the slower error generation time may not always be a problem. - #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling - #code which has no use for the enhanced error info. - #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. - #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system - #todo - #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error - #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) - - #todo - document unnamed leaders and unnamed values where -min and/or -max specified - #e.g punk::args::parse {} withdef {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} - #only |?-x?|string|... is shown in the output table. - #should be something like: - # |arg | - # |?-x? | - # |arg | - # |?arg...?| - # Where/how to specify counts? - #also.. - # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? - # - - - if {[catch {package require punk::ansi}]} { - proc punk::args::a {args} {} - proc punk::args::a+ {args} {} - } else { - namespace eval ::punk::args { - namespace import ::punk::ansi::a ::punk::ansi::a+ - } - } - #limit colours to standard 16 so that themes can apply to help output - variable arg_error_isrunning - if {$arg_error_isrunning} { - error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" - } - - if {[llength $args] %2 != 0} { - error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" - } - - set arg_error_isrunning 1 - - set badarg "" - set parsedargs [dict create] ;#dict with keys: leaders,opts,values,received,solos,multis (as from punk::args::parse) - set goodargs [list] - set returntype table ;#table as string - set as_error 1 ;#usual case is to raise an error - set scheme error - set form 0 - dict for {k v} $args { - set fullk [tcl::prefix::match -error "" {-badarg -parsedargs -aserror -return -scheme -form} $k] - switch -- $fullk { - -badarg { - set badarg $v - } - -parsedargs { - #todo? - dict for {set setinfo} $v { - switch -- $set { - received { - foreach {r rpos} $setinfo { - if {$r ni $goodargs} { - lappend goodargs $r - } - } - } - } - } - set parsedargs $v - } - -aserror { - if {![string is boolean -strict $v]} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" - } - set as_error $v - } - -scheme { - set scheme $v - } - -return { - if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" - } - set returntype $v - } - -form { - set form $v - } - default { - set arg_error_isrunning 0 - error "arg_error invalid option $k. Known_options: -badarg -parsedargs -aserror -scheme -return -form" - } - } - } - #todo - scheme - use config and iterm toml definitions etc - switch -- $scheme { - "" - -nocolor - -nocolour { - set scheme nocolour - } - info - error {} - default { - set scheme na - } - } - set formnames [dict get $spec_dict form_names] - if {[string is integer -strict $form]} { - if {$form < 0 || $form > [llength $formnames]-1} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" - } - set selected_forms [list [lindex $formnames $form]] - } else { - if {$form eq "*"} { - set selected_forms $formnames - } else { - if {$form in $formnames} { - set selected_forms [list $form] - } else { - set arg_error_isrunning 0 - error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" - } - } - } - - - #hack some basics for now. - #for coloured schemes - use bold as well as brightcolour in case colour off. - array set CLR {} - set CLR(errormsg) [a+ brightred] - set CLR(title) "" - set CLR(check) [a+ brightgreen] - set CLR(solo) [a+ brightcyan] - set CLR(choiceprefix) [a+ underline] - set CLR(badarg) [a+ brightred] - set CLR(goodarg) [a+ green strike] - set CLR(goodchoice) [a+ reverse] - set CLR(linebase_header) [a+ white] - set CLR(cmdname) [a+ brightwhite] - set CLR(groupname) [a+ bold] - set CLR(ansiborder) [a+ bold] - set CLR(ansibase_header) [a+ bold] - set CLR(ansibase_body) [a+ white] - - switch -- $scheme { - nocolour { - set CLR(errormsg) [a+ bold] - set CLR(title) [a+ bold] - set CLR(check) "" - set CLR(solo) "" - set CLR(badarg) [a+ reverse] ;#? experiment - set CLR(goodarg) [a+ strike] - set CLR(cmdname) [a+ bold] - set CLR(linebase_header) "" - set CLR(linebase) "" - set CLR(ansibase_body) "" - } - info { - set CLR(errormsg) [a+ brightred bold] - set CLR(title) [a+ brightyellow bold] - set CLR(check) [a+ brightgreen bold] - set CLR(choiceprefix) [a+ brightgreen bold] - set CLR(groupname) [a+ cyan bold] - set CLR(ansiborder) [a+ brightcyan bold] - set CLR(ansibase_header) [a+ cyan] - set CLR(ansibase_body) [a+ white] - } - error { - set CLR(errormsg) [a+ brightred bold] - set CLR(title) [a+ brightcyan bold] - set CLR(check) [a+ brightgreen bold] - set CLR(choiceprefix) [a+ brightgreen bold] - set CLR(groupname) [a+ cyan bold] - set CLR(ansiborder) [a+ brightyellow bold] - set CLR(ansibase_header) [a+ yellow] - set CLR(ansibase_body) [a+ white] - } - na { - } - } - - - #set RST [a] - set RST "\x1b\[m" - set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. - - #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error - #e.g list_as_table - - # use basic colours here to support terminals without extended colours - #todo - add checks column (e.g -minsize -maxsize) - set errmsg $msg - if {![catch {package require textblock}]} { - set has_textblock 1 - } else { - set has_textblock 0 - #couldn't load textblock package - #just return the original errmsg without formatting - } - set use_table 0 - if {$has_textblock && $returntype in {table tableobject}} { - set use_table 1 - } - set errlines [list] ;#for non-textblock output - if {[catch { - if {$use_table} { - append errmsg \n - } else { - if {($returntype in {table tableobject}) && !$has_textblock} { - append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n - } else { - append errmsg \n - } - } - set cmdname [Dict_getdef $spec_dict cmd_info -name ""] - set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] - - set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] - set docurl [Dict_getdef $spec_dict doc_info -url ""] - - #set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] - #set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] - #if {"$argdisplay_header$argdisplay_body" eq ""} { - # set is_custom_argdisplay 0 - #} else { - # set is_custom_argdisplay 1 - #} - - #temp - TODO - set argdisplay_header "" - set argdisplay_body "" - set is_custom_argdisplay 0 - - - set blank_header_col [list] - if {$cmdname ne ""} { - lappend blank_header_col "" - set cmdname_display $CLR(cmdname)$cmdname$RST - } else { - set cmdname_display "" - } - if {$cmdhelp ne ""} { - lappend blank_header_col "" - #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] - set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] - } else { - set cmdhelp_display "" - } - if {$docurl ne ""} { - lappend blank_header_col "" - set docurl_display [a+ white]$docurl$RST - } else { - set docurl_display "" - } - #synopsis - set synopsis "" - set form_info [dict get $spec_dict form_info] - dict for {fid finfo} $form_info { - set form_synopsis [Dict_getdef $finfo -synopsis ""] - if {$form_synopsis eq ""} { - #todo - set form_synopsis [punk::args::synopsis -form $fid [dict get $spec_dict id]] - if {[string length $form_synopsis] > 90} { - set form_synopsis [punk::args::synopsis -return summary -form $fid [dict get $spec_dict id]] - } - if {[string match (autodef)* $form_synopsis]} { - set form_synopsis [string range $form_synopsis 9 end] - } - } - if {$fid in $selected_forms} { - set form_synopsis [punk::ansi::a+ underline]$form_synopsis[punk::ansi::a+ nounderline] - } - append synopsis $form_synopsis \n - } - if {$synopsis ne ""} { - set synopsis [string trimright $synopsis \n] - lappend blank_header_col "" - } - - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - if {$use_table} { - set t [textblock::class::table new "$CLR(title)Usage$RST"] - $t add_column -headers $blank_header_col -minwidth 3 - $t add_column -headers $blank_header_col - - if {!$is_custom_argdisplay} { - lappend blank_header_col "" - #spanned columns in default argdisplay area - $t add_column -headers $blank_header_col ;#Default - $t add_column -headers $blank_header_col ;#Multi - $t add_column -headers $blank_header_col ;#Help - set arg_colspans {1 4 0 0 0} - } else { - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - set arg_colspans {1 1} - } - } - set h 0 - if {$cmdname ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] - } else { - lappend errlines "COMMAND: $cmdname_display" - } - incr h - } - if {$cmdhelp ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] - } else { - lappend errlines "Description: $cmdhelp_display" - } - incr h - } - if {$docurl ne ""} { - if {![catch {package require punk::ansi}]} { - set docurl [punk::ansi::hyperlink $docurl] - } - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] - } else { - lappend errlines "$docname $docurl_display" - } - incr h - } - if {$synopsis ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Synopsis: [punk::ansi::ansiwrap brightwhite $synopsis]] - } else { - #todo - lappend errlines "Synopsis:\n$synopsis" - } - incr h - } - - - if {$use_table} { - if {$is_custom_argdisplay} { - if {$argdisplay_header ne ""} { - $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] - } - } else { - $t configure_header $h -values {Arg Type Default Multi Help} - } - } else { - lappend errlines " --ARGUMENTS-- " - } - - if {$is_custom_argdisplay} { - if {$use_table} { - #using overall container table - #header already added - #TODO - review textblock::table features - #we can't currently span columns within the table body. - #This feature could allow hidden data columns (and sort on hidden col?) - #potentially require coordination with header colspans? - $t add_row [list "" $argdisplay_body] - } else { - if {$argdisplay_header ne ""} { - lappend errlines $argdisplay_header - } - lappend errlines {*}$argdisplay_body - } - } else { - - #set A_DEFAULT [a+ brightwhite Brightgreen] - set A_DEFAULT "" - set A_BADARG $CLR(badarg) - set A_GOODARG $CLR(goodarg) - set A_GOODCHOICE $CLR(goodchoice) - set greencheck $CLR(check)\u2713$RST ;#green tick - set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply - if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { - #A_PREFIX can resolve to empty string if colour off - #we then want to display underline instead - set A_PREFIX [a+ underline] - set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space - } else { - set A_PREFIXEND $RST - } - - #TODO - foreach fid - set fid [lindex $selected_forms 0] - set form_dict [dict get $spec_dict FORMS $fid] - - set opt_names [list] - set opt_names_display [list] - if {[llength [dict get $form_dict OPT_NAMES]]} { - if {![catch {package require punk::trie}]} { - set trie [punk::trie::trieclass new {*}[dict get $form_dict OPT_NAMES]] - set idents [dict get [$trie shortest_idents ""] scanned] - #todo - check opt_prefixdeny - - $trie destroy - foreach c [dict get $form_dict OPT_NAMES] { - set arginfo [dict get $form_dict ARG_INFO $c] - if {[dict get $arginfo -prefix]} { - set id [dict get $idents $c] - #REVIEW - if {$id eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $id] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail - } else { - lappend opt_names_display $c - } - #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] - lappend opt_names $c - } - } else { - set opt_names [dict get $form_dict OPT_NAMES] - set opt_names_display $opt_names - } - } - set leading_val_names [dict get $form_dict LEADER_NAMES] - set trailing_val_names [dict get $form_dict VAL_NAMES] - - #dict for {argname info} [tcl::dict::get $form_dict arg_info] { - # if {![string match -* $argname]} { - # lappend leading_val_names [lpop trailing_val_names 0] - # } else { - # break - # } - #} - #if {![llength $leading_val_names] && ![llength $opt_names]} { - # #all vals were actually trailing - no opts - # set trailing_val_names $leading_val_names - # set leading_val_names {} - #} - set leading_val_names_display $leading_val_names - set trailing_val_names_display $trailing_val_names - #puts "--> parsedargs: $parsedargs" - set parsed_leaders [Dict_getdef $parsedargs leaders {}] - set parsed_opts [Dict_getdef $parsedargs opts {}] - set parsed_values [Dict_getdef $parsedargs values {}] - - #display options first then values - foreach argumentset [list [list $leading_val_names_display $leading_val_names $parsed_leaders] [list $opt_names_display $opt_names $parsed_opts] [list $trailing_val_names_display $trailing_val_names $parsed_values]] { - lassign $argumentset argnames_display argnames parsedvalues - - foreach argshow $argnames_display arg $argnames { - set arginfo [dict get $form_dict ARG_INFO $arg] - if {[dict exists $arginfo -default]} { - set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" - } else { - set default "" - } - set help [Dict_getdef $arginfo -help ""] - set allchoices_originalcase [list] - set choices [Dict_getdef $arginfo -choices {}] - set choicegroups [Dict_getdef $arginfo -choicegroups {}] - set choicemultiple [dict get $arginfo -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] - set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] - if {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - set is_multiple 1 - } else { - set multiple "" - set is_multiple 0 - } - if {[dict exists $choicegroups ""]} { - dict lappend choicegroups "" {*}$choices - } else { - set choicegroups [dict merge [dict create "" $choices] $choicegroups] - } - dict for {groupname clist} $choicegroups { - lappend allchoices_originalcase {*}$clist - } - set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] - - if {$has_choices} { - if {$help ne ""} {append help \n} - if {[dict get $arginfo -nocase]} { - set casemsg " (case insensitive)" - set allchoices_test [string tolower $allchoices_originalcase] - } else { - set casemsg " (case sensitive)" - set allchoices_test $allchoices_originalcase - } - if {[dict get $arginfo -choiceprefix]} { - set prefixmsg " (choice prefix allowed)" - } else { - set prefixmsg "" - } - set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] - set choiceinfodict [Dict_getdef $arginfo -choiceinfo {}] - set formattedchoices [dict create] ;#use dict rather than array to preserve order - append help " Choices$prefixmsg$casemsg" - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - if {$choicemultiple_max == -1} { - append help \n " The value can be a list of $choicemultiple_min or more of these choices" - } else { - if {$choicemultiple_min eq $choicemultiple_max} { - append help \n " The value must be a list of $choicemultiple_min of these choices" - } else { - append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" - } - } - } - if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c [join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } else { - #set formattedchoices $choicegroups - #set formattedchoices [dict get $arginfo -choices] - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c [join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } - } else { - if {[catch { - set trie [punk::trie::trieclass new {*}$allchoices_test] - set idents [dict get [$trie shortest_idents ""] scanned] - if {[dict get $arginfo -nocase]} { - #idents were calculated on lcase - remap keys in idents to original casing - set actual_idents $idents - foreach ch $allchoices_originalcase { - if {![dict exists $idents $ch]} { - #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting - #The actual testing is done in get_dict - dict set actual_idents $ch [dict get $idents [string tolower $ch]] - } - } - set idents $actual_idents - #puts "-----" - #puts "idents $idents" - } - - $trie destroy - dict for {groupname clist} $choicegroups { - foreach c $clist { - if {$c in $choiceprefixdenylist} { - set shortestid $c - } else { - set shortestid [dict get $idents $c] - } - if {$shortestid eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $shortestid] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set mk " [join $markers {}]" - } else { - set mk "" - } - set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]$mk" - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - #puts "-- parsed:$parsedvalues arg:$arg c:$c" - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } errM]} { - #this failure can happen if -nocase is true and there are ambiguous entries - #e.g -nocase 1 -choices {x X} - puts stderr "prefix marking failed\n$errM" - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c [join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } else { - #set formattedchoices $choicegroups - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c[join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } - - } - } - set choicetable_objects [list] - set choicetable_footers [dict create] - dict for {groupname formatted} $formattedchoices { - set numcols $choicecolumns ;#todo - dynamic? - if {[llength $formatted] < $numcols} { - #don't show blank cells if single line of results - set numcols [llength $formatted] - } - if {$numcols > 0} { - if {$use_table} { - #risk of recursing - #TODO -title directly in list_as_table - set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] - lappend choicetable_objects $choicetableobj - $choicetableobj configure -title $CLR(groupname)$groupname - #append help \n[textblock::join -- " " [$choicetableobj print]] - } else { - if {$groupname ne ""} { - append help \n \n "$CLR(groupname)Group: $groupname$RST" - } else { - append help \n - } - append help \n [join $formatted \n] - } - } else { - #we were given an empty set of choices. - #probably an error in the definition - but could happen if dynamically generated. - #(e.g ensemble where unknown mechanism is used for subcommands?) - #better to just display that there were none rather than totally break the usage output. - if {$usetable} { - #these will be displayed after all table entries - if {$groupname eq ""} { - dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" - } else { - dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" - } - } else { - if {$groupname eq ""} { - append help \n " " $CLR(errormsg)(no choices defined)$RST - } else { - append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST - } - } - } - } - set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width - foreach obj $choicetable_objects { - dict lappend twidths_by_colcount [$obj column_count] [$obj width] - } - foreach obj $choicetable_objects { - set cols [$obj column_count] - set widths [dict get $twidths_by_colcount $cols] - set max [tcl::mathfunc::max {*}$widths] - $obj configure -minwidth $max ;#expand smaller ones - set i 0 - while {$i < $cols} { - #keep text aligned left on expanded tables - $obj configure_column $i -blockalign left - incr i - } - - append help \n[textblock::join -- " " [$obj print]] - #set ansititle [dict get [$obj configure -title] value] - $obj destroy - } - if {[dict size $choicetable_footers]} { - foreach groupname [dict keys $formattedchoices] { - if {[dict exists $choicetable_footers $groupname]} { - append help \n [dict get $choicetable_footers $groupname] - } - } - } - - #review. use -type to restrict additional choices - may be different to values in the -choices - if {![dict get $arginfo -choicerestricted]} { - #when -choicemultiple - the -type refers to each selection - if {[dict get $arginfo -type] eq "string"} { - append help "\n (values not in defined choices are allowed)" - } else { - append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" - } - } - } - if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { - if {$is_multiple} { - set argshow "?${argshow}...?" - } else { - set argshow "?${argshow}?" - } - } else { - if {$is_multiple} { - set argshow "${argshow}..." - } - } - set typeshow [dict get $arginfo -type] - if {$typeshow eq "none"} { - set typeshow "$typeshow $soloflag" - } - if {[dict exists $arginfo -minsize]} { - append typeshow \n "-minsize [dict get $arginfo -minsize]" - } - if {[dict exists $arginfo -maxsize]} { - append typeshow \n "-maxsize [dict get $arginfo -maxsize]" - } - if {[dict exists $arginfo -range]} { - append typeshow \n "-range [dict get $arginfo -range]" - } - - if {$use_table} { - $t add_row [list $argshow $typeshow $default $multiple $help] - if {$arg eq $badarg} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG - } elseif {$arg in $goodargs} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $A_GOODARG - } - } else { - #review - formatting will be all over the shop due to newlines in typesshow, help - set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" - if {$arg eq $badarg} { - set arghelp [punk::ansi::ansiwrap -rawansi $A_BADARG $arghelp] - } elseif {$arg in $goodargs} { - set arghelp [punk::ansi::ansiwrap -rawansi $A_GOODARG $arghelp] - } - foreach ln [split $help \n] { - append arghelp " $ln" \n - } - lappend errlines $arghelp - } - } - } - } ;#end is_custom_argdisplay - - if {$use_table} { - $t configure -show_hseps 0\ - -show_header 1\ - -ansibase_body $CLR(ansibase_body)\ - -ansibase_header $CLR(ansibase_header)\ - -ansiborder_header $CLR(ansiborder)\ - -ansiborder_body $CLR(ansiborder) - - $t configure -maxwidth 80 ;#review - if {$returntype ne "tableobject"} { - append errmsg [$t print] - #returntype of table means just the text of the table - $t destroy - } - } else { - append errmsg [join $errlines \n] - } - } errM]} { - catch {$t destroy} - append errmsg \n - append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n - append errmsg "$errM" \n - append errmsg "$::errorInfo" - - } - set arg_error_isrunning 0 - if {$use_table} { - #assert returntype is one of table, tableobject - set result $errmsg ;#default if for some reason table couldn't be used - if {$returntype eq "tableobject"} { - if {[info object isa object $t]} { - set result $t - } - } - } else { - set result $errmsg - } - if {$as_error} { - #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. - #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) - uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] - } else { - return $result - } - } - - - lappend PUNKARGS [list { - @dynamic - @id -id ::punk::args::usage - @cmd -name punk::args::usage -help\ - "Return usage information for a command identified by an id. - - This will only work for commands where a punk::args definition exists - for the command and an id has been defined for it. The id for custom - help for a command should match the fully qualified name of the command. - - Many commands (such as ensembles and oo objects) may have argument - documentation generated dynamically and may not yet have an id. - IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. - - Generally punk::ns::arginfo (aliased as i in the punk shell) should - be used in preference - as it will search for a documentation - mechanism and call punk::args::usage as necessary. - " - -return -default table -choices {string table tableobject} - }\ - {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}}\ - {${[punk::args::resolved_def -types opts ::punk::args::resolved_def -form]}}\ - { - - @values -min 0 -max 1 - id -help\ - "Exact id. - Will usually match the command name" - }] - proc usage {args} { - #lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received - lassign [dict values [punk::args::parse $args withid ::punk::args::usage]] leaders opts values received - set id [dict get $values id] - set real_id [real_id $id] - if {$real_id eq ""} { - error "punk::args::usage - no such id: $id" - } - #-scheme punk_info ?? - arg_error "" [punk::args::get_spec $real_id] {*}$opts -aserror 0 - } - - lappend PUNKARGS [list { - @id -id ::punk::args::get_by_id - @cmd -name punk::args::get_by_id - @values -min 1 - id - arglist -type list -help\ - "list containing arguments to be parsed as per the - argument specification identified by the supplied id." - }] - - - #deprecate? - proc get_by_id {id arglist} { - set definitionlist [punk::args::raw_def $id] - if {[llength $definitionlist] == 0} { - error "punk::args::get_by_id - no such id: $id" - } - #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] - tailcall ::punk::args::get_dict $definitionlist $arglist - } - - #consider - - #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) - #parse ?-flag val?... -- $arglist withid $id - #parse ?-flag val?... -- $arglist withdef $def ?$def?... - - #an experiment.. ideally we'd like arglist at the end? - #parse_withid ?-flag val?.. $id $arglist - #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? - #no possible equivalent for parse_withdef ??? - - lappend PUNKARGS [list { - @id -id ::punk::args::parse - @cmd -name punk::args::parse -help\ - "parse and validate command arguments based on a definition. - - In the 'withid' form the definition is a pre-existing record that has been - created with ::punk::args::define, or indirectly by adding a definition to - the PUNKARGS variable in a namespace which is then registered in - punk::args::register::NAMESPACES, or by a previous call to punk::parse - using 'withdef' and a definition block containing an @id -id directive. - - In the 'withdef' form - the definition is created on the first call and - cached thereafter, if the id didn't already exist. - - form1: parse $arglist ?-flag val?... withid $id - form2: parse $arglist ?-flag val?... withdef $def ?$def? - see punk::args::define - - Returns a dict of information regarding the parsed arguments - example of basic usage for single option only: - punk::args::define { - @id -id ::myns::myfunc - @cmd -name myns::myfunc - @leaders -min 0 -max 0 - @opts - -configfile -type existingfile - #type none makes it a solo flag - -verbose -type none - @values -min 0 -max 0 - } - proc myfunc {args} { - set argd [punk::args::parse $args withid ::myns::myfunc] - lassign [dict values $argd] leaders opts values received solos - if {[dict exists $received] -configfile} { - puts \"have option for existing file [dict get $opts -configfile]\" - } - } - The leaders, opts, values keys in the parse result dict are proper dicts. - The received key is dict-like but can have repeated keys for arguments than can - accept multiples. The value for each received element is the ordinal position. - The solos key refers to a list of solo flags received (those specified with - -type none). This is generally only useful to assist in passing arguments on - to another procedure which also requires solos, because the opts dict contains - solo flags with a 1 value or a list of 1's if it was a solo with -multiple true - specified. - " - @form -form {withid withdef} - @leaders -min 1 -max 1 - arglist -type list -optional 0 -help\ - "Arguments to parse - supplied as a single list" - - @opts - -form -type list -default * -help\ - "Restrict parsing to the set of forms listed. - Forms are the orthogonal sets of arguments a - command can take - usually described in 'synopsis' - entries." - #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance - #todo - configurable per interp/namespace - -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} - - @values -min 2 - - @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" - @values -max 2 - withid -type literal -help\ - "The literal value 'withid'" - id -type string -help\ - "id of punk::args definition for a command" - - - @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" - withdef -type literal -help\ - "The literal value 'withdef'" - - #todo - make -dynamic obsolete - use @dynamic directive instead - def -type string -multiple 1 -optional 0 -help\ - "Each remaining argument is a block of text - defining argument definitions. - As a special case, -dynamic may be - specified as the 1st 2 arguments. These are - treated as an indicator to punk::args about - how to process the definition." - - }] - proc parse {args} { - set tailtype "" ;#withid|withdef - if {[llength $args] < 3} { - #error "punk::args::parse - invalid call. < 3 args" - punk::args::parse $args withid ::punk::args::parse - } - set opts_and_vals $args - set parseargs [lpop opts_and_vals 0] - - set opts [list] - set values [list] - for {set i 0} {$i < [llength $opts_and_vals]} {incr i} { - if {[string match -* [lindex $opts_and_vals $i]]} { - if {[catch { - lappend opts [lpop opts_and_vals 0] [lpop opts_and_vals 0] - }]} { - punk::args::parse $args withid ::punk::args::parse - } - incr i -1 - #lappend opts $a [lindex $opts_and_vals $i] - } else { - break - } - } - #set values [lrange $opts_and_vals $i end] - set values $opts_and_vals - #puts "---values: $values" - set tailtype [lindex $values 0] - set tailargs [lrange $values 1 end] - - - #set split [lsearch -exact $tailargs withid] - #if {$split < 0} { - # set split [lsearch -exact $tailargs withdef] - # if {$split < 0} { - # #punk::args::usage arg_error? - # #error "punk::args::parse - invalid call. keyword withid|withdef required" - # punk::args::parse $args withid ::punk::args::parse - # } else { - # set tailtype withdef - #} - #} else { - # set tailtype withid - #} - #set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. - - - #if {[llength $opts] % 2} { - #error "punk::args::parse Even number of -flag val pairs required after arglist" - #} - - #Default the -errorstyle to enhanced - # (slowest on unhappy path - but probably clearest for playing with new APIs interactively) - # - application devs should distribute a config file with an errorstyle override if desired. - # - devs who prefer a different default for interactive use should create a config for it. (todo) - set defaultopts [dict create\ - -form {*}\ - -errorstyle enhanced\ - ] - - #todo - load override_errorstyle from configuration - #dict set defaultopts -errorstyle $ - #puts "def: $defaultopts opts: $opts" - set opts [dict merge $defaultopts $opts] - dict for {k v} $opts { - switch -- $k { - -form - -errorstyle { - } - default { - #punk::args::usage $args withid ::punk::args::parse ?? - #error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" - punk::args::parse $args withid ::punk::args::parse - } - } - } - switch -- $tailtype { - withid { - if {[llength $tailargs] != 1} { - #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - punk::args::parse $args withid ::punk::args::parse - } - set id [lindex $tailargs 0] - #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" - set deflist [raw_def $id] - if {[llength $deflist] == 0} { - error "punk::args::parse - no such id: $id" - } - } - withdef { - set deflist $tailargs - if {[llength $deflist] < 1} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" - } - default { - error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" - } - } - try { - set result [punk::args::get_dict $deflist $parseargs -form [dict get $opts -form]] - } trap {PUNKARGS VALIDATION} {msg erroropts} { - set opt_errorstyle [dict get $opts -errorstyle] - - #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - - - set ecode [dict get $erroropts -errorcode] - #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... - set msg [string map [list %caller% [Get_caller]] $msg] - switch -- $opt_errorstyle { - minimal { - return -options [list -code error -errorcode $ecode] $msg - } - basic { - #No table layout - unix manpage style - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg -form [dict get $opts -form]] - } - return -options [list -code error -errorcode $ecode] $msg - } - standard { - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] - } - return -options [list -code error -errorcode $ecode] $msg - } - enhanced { - set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below) - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - set ecode_summary [lrange $ecode 0 2] - if {$badarg ne ""} { - lappend ecode_summary -badarg $badarg - } - catch {package require punk::lib} - if {[package provide punk::lib] ne ""} { - append msg \n [punk::lib::showdict -roottype list $estack */*] - } - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] - append msg \n "::errorCode summary: $ecode_summary" - return -options [list -code error -errorcode $ecode] $msg - } else { - #why? todo? - append msg \n "(enhanced error information unavailable)" - append msg \n "::errorCode summary: $ecode_summary" - return -options [list -code error -errorcode $ecode] $msg - } - } - debug { - puts stderr "errorstyle debug not implemented" - return -options [list -code error -errorcode $ecode] $msg - } - default { - puts stderr "errorstyle $opt_errorstyle not recognised: expected one of minimal basic standard enhanced debug" - return -options [list -code error -errorcode $ecode] $msg - } - } - } trap {PUNKARGS} {msg erropts} { - append msg \n "Unexpected PUNKARGS error" - return -options [list -code error -errorcode $ecode] $msg - } trap {} {msg erroropts} { - #review - #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. - #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. - throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] - } - return $result - } - proc parseXXX {args} { - #no solo flags allowed for parse function itself. (ok for arglist being parsed) - set opts [dict create] ;#repeated flags will override earlier. That's ok here. - set arglist {} - set got_arglist 0 - set tailtype "" ;#withid|withdef - set id "" - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {[string match -* $a]} { - dict set opts $a [lindex $args $i+1] - incr i - } else { - set arglist $a - set got_arglist 1 - set tailtype [lindex $args $i+1] - if {$tailtype eq "withid"} { - if {[llength $args] != $i+3} { - error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - } - set id [lindex $args $i+2] - break - } elseif {$tailtype eq "withdef"} { - if {[llength $args] < $i+3} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - set deflist [lrange $args $i+2 end] - break - } else { - error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" - } - } - } - if {!$got_arglist} { - error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." - } - #assert tailtype eq withid|withdef - if {$tailtype eq "withid"} { - #assert $id was provided - return "parse [llength $arglist] args withid $id, options:$opts" - } else { - #assert llength deflist >=1 - return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" - } - #TODO - } - - #todo? - a version of get_dict that directly supports punk::lib::tstr templating - #rename get_dict - # - - #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 get_dict {deflist rawargs args} { - #see arg_error regarding considerations around unhappy-path performance - - if {[llength $args] % 2 != 0} { - error "punk::args::get_dict args must be a dict of option value pairs" - } - set defaults [dict create\ - -form *\ - ] - set opts [dict merge $defaults $args] - dict for {k v} $opts { - switch -- $k { - -form {} - default { - error "punk::args::get_dict Unexpected option '$k' Known options -form" - } - } - } - - - #*** !doctools - #[call [fun get_dict] [arg deflist] [arg rawargs] [arg args]] - #[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 values - #[para]ARGUMENTS: - #[list_begin arguments] - #[arg_def list-of-multiline-string deflist] - #[para] These are blocks 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 defining a flag 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 - #[para]Each optionspec line defining a positional argument is of the form: - #[para]argumentname -key val -ky2 val2... - #[para]where the valid keys for each option specification are: -default -type -range -choices - #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value - #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. - #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. - #[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, - #but it could be a manually constructed list of values made for example from positional args defined in the proc. - #[list_end] - #[para] - - #consider line-processing example below for which we need info complete to determine record boundaries - #punk::args::get_dict [list { - # @opts - # -opt1 -default {} - # -opt2 -default { - # etc - # } - # @values -multiple 1 - #}] $args - - - - - #rawargs: args values to be parsed - #we take a definition list rather than resolved argspecs - because the definition could be dynamic - - #if definition has been seen before, - #define will either return a permanently cached argspecs (-dynamic 0) - or - # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. - set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]] - - # ----------------------------------------------- - # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) - tcl::dict::with argspecs {} ;#turn keys into vars - #e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info,id_info,form_names - # ----------------------------------------------- - set opt_form [dict get $opts -form] - if {$opt_form eq "*"} { - set selected_forms $form_names - } elseif {[string is integer -strict $opt_form]} { - if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { - error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set selected_forms [list [lindex $form_names $opt_form]] - } else { - if {$opt_form ni $form_names} { - error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set selected_forms [list $opt_form] - } - - - #puts "-arg_info->$arg_info" - set flagsreceived [list] ;#for checking if required flags satisfied - set solosreceived [list] - set multisreceived [list] - #secondary purpose: - #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 ? - - # -- --- --- --- - # Handle leading positionals - # todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ? - - #todo - handle multiple fids? - set fid [lindex $selected_forms 0] - set formdict [dict get $FORMS $fid] - tcl::dict::with formdict {} - #populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc - if {$VAL_MIN eq ""} { - set valmin 0 - set VAL_MIN 0 - } else { - set valmin $VAL_MIN - } - - set pre_values {} - - set argnames [tcl::dict::keys $ARG_INFO] - set optnames [lsearch -all -inline $argnames -*] - set ridx 0 - set rawargs_copy $rawargs - set leader_posn_name "" - set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) - set is_multiple 0 ;#last leader may be multi - if {$LEADER_MAX != 0} { - foreach r $rawargs_copy { - if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { - break - } - if {$ridx == [llength $LEADER_NAMES]-1} { - #at last named leader - set leader_posn_name [lindex $LEADER_NAMES $ridx] - if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { - set is_multiple 1 - } - } elseif {$ridx > [llength $LEADER_NAMES]-1} { - #beyond names - retain name if -multiple was true - if {!$is_multiple} { - set leader_posn_name "" - } - } else { - set leader_posn_name [lindex $LEADER_NAMES $ridx] ;#may return empty string - } - if {$r eq "--"} { - #review end of opts marker: '--' can't be a leader (but can be a value) - break - } - - #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option - if {[tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { - set matchopt [::tcl::prefix::match -error {} $optnames $r] - if {$matchopt ne ""} { - #flaglike matches a known flag - don't treat as leader - break - } - #if {![string match -* [lindex $argnames $ridx]]} {} - if {$leader_posn_name ne ""} { - #there is a named leading positional for this position - #The flaglooking value doesn't match an option - so treat as a leader - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - incr ridx - continue - } else { - break - } - } - - #for each branch - break or lappend - if {$leader_posn_name ne ""} { - if {$leader_posn_name ni $LEADER_REQUIRED} { - #optional leader - - #most adhoc arg processing will allocate based on number of args rather than matching choice values first - #(because a choice value could be a legitimate data value) - - #review - option to process in this manner? - #first check if the optional leader value is a match for a choice ? - #if {[dict exists $arg_info $leader_posn_name -choices]} { - # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] [lindex $rawargs 0]] - # if {$vmatch ne ""} { - # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values - # lappend pre_values [lpop rawargs 0] - # incr ridx - # continue - # } - #} - - #check if enough rawargs to fill any required values - if {$VAL_MIN > 0 && [llength $rawargs] <= $VAL_MIN || [llength $rawargs] <= [llength $VAL_REQUIRED]} { - break - } else { - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #required - if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { - #already accepted at least one value - requirement satisfied - now equivalent to optional - if {$VAL_MIN > 0 && [llength $rawargs] <= $VAL_MIN || [llength $rawargs] <= [llength $VAL_REQUIRED]} { - break - } - } - #if we didn't break - requirement is not yet satisfied, or is satisfied but stil enough rawargs for required values - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #unnamed leader - if {$LEADER_MIN ne "" } { - if {$ridx > $LEADER_MIN-1} { - if {$LEADER_MAX ne "" && $ridx == $LEADER_MAX} { - break - } else { - if {$VAL_MIN ne ""} { - if {[llength $rawargs] > $VAL_MIN} { - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } else { - break - } - } else { - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } - } else { - #haven't reached LEADER_MIN - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - break - } - } - - incr ridx - } ;# end foreach r $rawargs_copy - } - - set argstate $ARG_INFO ;#argstate may have entries added - set arg_checks $ARG_CHECKS - - #JJJJ - if {$LEADER_MIN eq ""} { - set leadermin 0 - } else { - set leadermin $LEADER_MIN - } - if {$LEADER_MAX eq ""} { - set leadermax -1 - } else { - set leadermax $LEADER_MAX - } - - if {$VAL_MAX eq ""} { - set valmax -1 - } else { - set valmax $VAL_MAX - } - - #assert leadermax leadermin are numeric - #assert - rawargs has been reduced by leading positionals - - set opts [dict create] ;#don't set to OPT_DEFAULTS here - - - set leaders [list] - set arglist {} - set post_values {} - #valmin, valmax - #puts stderr "rawargs: $rawargs" - #puts stderr "argstate: $argstate" - if {[lsearch $rawargs -*] >= 0} { - #at least contains flaglike things.. - set maxidx [expr {[llength $rawargs] -1}] - if {$valmax == -1} { - set vals_total_possible [llength $rawargs] - set vals_remaining_possible $vals_total_possible - } else { - set vals_total_possible $valmax - set vals_remaining_possible $vals_total_possible - } - for {set i 0} {$i <= $maxidx} {incr i} { - set a [lindex $rawargs $i] - set remaining_args_including_this [expr {[llength $rawargs] - $i}] - #lowest valmin is 0 - if {$remaining_args_including_this <= $valmin} { - # if current arg is -- it will pass through as a value here - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - - #exlude argument with whitespace from being a possible option e.g dict - if {[tcl::string::match -* $a] && !([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { - if {$a eq "--"} { - #remaining num args <= valmin already covered above - if {$valmax != -1} { - #finite max number of vals - if {$remaining_args_including_this == $valmax} { - #assume it's a value. - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - } else { - #assume it's an end-of-options marker - lappend flagsreceived -- - set arglist [lrange $rawargs 0 $i] - set post_values [lrange $rawargs $i+1 end] - } - } else { - #unlimited number of post_values accepted - #treat this as eopts - we don't care if remainder look like options or not - lappend flagsreceived -- - set arglist [lrange $rawargs 0 $i] - set post_values [lrange $rawargs $i+1 end] - } - break - } else { - set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] - if {$fullopt ne ""} { - if {![tcl::dict::get $argstate $fullopt -prefix] && $a ne $fullopt} { - #attempt to use a prefix when not allowed - #review - by ending opts here - we dont' get the clearest error msgs - # may *sometimes* be better to raise a PUNKARGS VALIDATION (invalidoption) error - # (but it may actually be the first value that just happens to be flaglike) - #todo - check for subsequent valid flags or -- marker? - #consider for example 'file delete -f -- old.txt' - #If we just end option-processing, the punk::args parser would pass {-f -- old.txt} as values - #whereas the builtin file arg parser alerts that -f is a bad option - set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg - #set arglist [lrange $rawargs 0 $i-1] - #set post_values [lrange $rawargs $i end] - #break - } - if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { - #non-solo - #check if it was actually a value that looked like a flag - if {$i == $maxidx} { - #if no optvalue following - assume it's a value - #(caller should probably have used -- before it) - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - - set flagval [lindex $rawargs $i+1] - if {[tcl::dict::get $argstate $fullopt -multiple]} { - #don't lappend to default - we need to replace if there is a default - if {$fullopt ni $flagsreceived} { - tcl::dict::set opts $fullopt [list $flagval] - } else { - tcl::dict::lappend opts $fullopt $flagval - } - if {$fullopt ni $multisreceived} { - lappend multisreceived $fullopt - } - } else { - tcl::dict::set opts $fullopt $flagval - } - #incr i to skip flagval - incr vals_remaining_possible -2 - if {[incr i] > $maxidx} { - set msg "Bad options for %caller%. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $fullopt index [expr {$i-1}]] -badarg $fullopt -argspecs $argspecs]] $msg - } - } else { - #solo - if {[tcl::dict::get $argstate $fullopt -multiple]} { - if {$fullopt ni $flagsreceived} { - #override any default - don't lappend to it - tcl::dict::set opts $fullopt 1 - } else { - tcl::dict::lappend opts $fullopt 1 - } - if {$fullopt ni $multisreceived} { - lappend multisreceived $fullopt - } - } else { - tcl::dict::set opts $fullopt 1 - } - incr vals_remaining_possible -1 - lappend solosreceived $fullopt ;#dups ok - } - lappend flagsreceived $fullopt ;#dups ok - } else { - #unmatched option flag - #comparison to valmin already done above - if {$valmax ne -1 && $remaining_args_including_this <= $valmax} { - #todo - look at optspec_default and see if solo/vs opt-val pair - #we may need to lookahead by 2 regarding valmax valmin - - #even with optany - assume an unknown within the space of possible values is a value - #unmatched option in right position to be considered a value - treat like eopts - #review - document that an unspecified arg within range of possible values will act like eopts -- - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - if {$OPT_ANY} { - set newval [lindex $rawargs $i+1] - #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option - tcl::dict::set argstate $a $OPTSPEC_DEFAULTS ;#use default settings for unspecified opt - tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS - if {[tcl::dict::get $argstate $a -type] ne "none"} { - if {[tcl::dict::get $argstate $a -multiple]} { - tcl::dict::lappend opts $a $newval - if {$a ni $multisreceived} { - lappend multisreceived $a - } - } else { - tcl::dict::set opts $a $newval - } - if {[incr i] > $maxidx} { - set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg - #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a - } - incr vals_remaining_possible -2 - } else { - #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none - if {[tcl::dict::get $argstate $a -multiple]} { - if {![tcl::dict::exists $opts $a]} { - tcl::dict::set opts $a 1 - } else { - tcl::dict::lappend opts $a 1 - } - if {$a ni $multisreceived} { - lappend multisreceived $a - } - } else { - tcl::dict::set opts $a 1 - } - incr vals_remaining_possible -1 - lappend solosreceived $a - } - lappend flagsreceived $a ;#adhoc flag as supplied - } else { - if {[llength $OPT_NAMES]} { - set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" - } else { - set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" - } - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg - #arg_error $errmsg $argspecs -badarg $fullopt - } - } - } - } else { - #not flaglike - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - } - #set values [list {*}$pre_values {*}$post_values] - set leaders $pre_values - set values $post_values - } else { - set leaders $pre_values - set values $rawargs - #set values [list {*}$pre_values {*}$rawargs] ;#no -flags detected - set arglist [list] - } - #puts stderr "--> arglist: $arglist" - #puts stderr "--> values: $values" - - #--------------------------------------- - set ordered_opts [dict create] - foreach o $OPT_NAMES { - if {[dict exists $opts $o]} { - dict set ordered_opts $o [dict get $opts $o] - } elseif {[dict exists $OPT_DEFAULTS $o]} { - dict set ordered_opts $o [dict get $OPT_DEFAULTS $o] - } - } - #add in possible '-any true' opts after the defined opts - dict for {o oval} $opts { - if {![dict exists $ordered_opts $o]} { - dict set ordered_opts $o $oval - } - } - set opts $ordered_opts - #--------------------------------------- - - - set positionalidx 0 ;#index for unnamed positionals (both leaders and values) - set ldridx 0 - set in_multiple "" - set leadernames_received [list] - - set num_leaders [llength $leaders] - #---------------------------------------- - #set leaders_dict $LEADER_DEFAULTS ;#wrong - set leaders_dict [dict create] - foreach lname [lrange $LEADER_NAMES 0 $num_leaders-1] { - dict set leaders_dict $lname {} - } - set leaders_dict [dict merge $leaders_dict $LEADER_DEFAULTS] - #---------------------------------------- - - foreach leadername $LEADER_NAMES ldr $leaders { - if {$ldridx+1 > $num_leaders} { - break - } - if {$leadername ne ""} { - if {[tcl::dict::get $argstate $leadername -multiple]} { - if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { - tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list - } else { - tcl::dict::lappend leaders_dict $leadername $ldr - } - set in_multiple $leadername - } else { - tcl::dict::set leaders_dict $leadername $ldr - } - lappend leadernames_received $leadername - } else { - if {$in_multiple ne ""} { - tcl::dict::lappend leaders_dict $in_multiple $ldr - lappend leadernames_received $in_multiple ;#deliberately allow dups! (as with opts and values) - } else { - tcl::dict::set leaders_dict $positionalidx $ldr - tcl::dict::set argstate $positionalidx $LEADERSPEC_DEFAULTS - tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS - lappend leadernames_received $positionalidx - } - } - incr ldridx - incr positionalidx - } - - - set validx 0 - set valname_multiple "" - set valnames_received [list] - - set num_values [llength $values] - #------------------------------------------ - #!!! review - ## Don't set values_dict to VAL_DEFAULTS - or order of values_dict will be intermittently wrong based on whether values have defaults - ## set values_dict $val_defaults - set values_dict [dict create] - foreach valname [lrange $VAL_NAMES 0 $num_values-1] { - dict set values_dict $valname {} - } - set values_dict [dict merge $values_dict $VAL_DEFAULTS] - #------------------------------------------ - set nameidx 0 - set start_position $positionalidx - for {set validx 0} {$validx < [llength $values]} {incr validx} { - set valname [lindex $VAL_NAMES $nameidx] - incr nameidx - set val [lindex $values $validx] - if {$valname ne ""} { - if {[llength $valname] == 1} { - set strideval $val - } else { - set strideval [list] - incr validx -1 - foreach v $valname { - incr validx - if {$validx > [llength $values]-1} { - set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname', but requires [llength $valname] values." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname] ] -argspecs $argspecs]] $msg - } - lappend strideval [lindex $values $validx] - } - } - - if {[tcl::dict::get $argstate $valname -multiple]} { - if {[tcl::dict::exists $VAL_DEFAULTS $valname]} { - #current stored val equals defined default - don't include default in the list we build up - tcl::dict::set values_dict $valname [list $strideval] ;#important to treat first element as a list - } else { - tcl::dict::lappend values_dict $valname $strideval - } - set valname_multiple $valname - } else { - tcl::dict::set values_dict $valname $strideval - } - lappend valnames_received $valname - } else { - if {$valname_multiple ne ""} { - if {[llength $valname_multiple] == 1} { - set strideval $val - } else { - set strideval [list] - incr validx -1 - foreach v $valname_multiple { - incr validx - if {$validx > [llength $values]-1} { - set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname_multiple', but requires [llength $valname_multiple] values." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname_multiple] ] -argspecs $argspecs]] $msg - } - lappend strideval [lindex $values $validx] - } - } - tcl::dict::lappend values_dict $valname_multiple $strideval - #name already seen - but must add to valnames_received anyway (as with opts and leaders) - lappend valnames_received $valname_multiple - } else { - tcl::dict::set values_dict $positionalidx $val - tcl::dict::set argstate $positionalidx $VALSPEC_DEFAULTS - tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS - lappend valnames_received $positionalidx - } - } - set positionalidx [expr {$start_position + $validx}] - } - #------------------------------------------ - - if {$leadermax == -1} { - #only check min - if {$num_leaders < $leadermin} { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected at least $leadermin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - } - } else { - if {$num_leaders < $leadermin || $num_leaders > $leadermax} { - if {$leadermin == $leadermax} { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected exactly $leadermin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - } else { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - } - } - } - - if {$valmax == -1} { - #only check min - if {$num_values < $valmin} { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $valmin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg - } - } else { - if {$num_values < $valmin || $num_values > $valmax} { - if {$valmin == $valmax} { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $valmin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg - } else { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $valmin and $valmax inclusive" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg - } - } - } - - #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options - - - #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 SHOULD? 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 - - #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? - #example timing difference: - #struct::set difference {x} {a b} - #normal interp 0.18 u2 vs safe interp 9.4us - #if {[llength [set missing [struct::set difference $OPT_REQUIRED $flagsreceived]]]} { - # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" - #} - #if {[llength [set missing [struct::set difference $VAL_REQUIRED $valnames_received]]]} { - # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" - #} - #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us - if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { - set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadermissing $missing received $leadernames_received] -argspecs $argspecs]] $msg - #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - if {[llength [set missing [punklib_ldiff $OPT_REQUIRED $flagsreceived]]]} { - set msg "Required option missing for %caller%. missing flags: '$missing' are marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list optionmissing $missing received $flagsreceived] -argspecs $argspecs]] $msg - #arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs - } - if {[llength [set missing [punklib_ldiff $VAL_REQUIRED $valnames_received]]]} { - set msg "Required value missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list valuemissing $missing received $valnames_received] -argspecs $argspecs]] $msg - #arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - - - #todo - truncate/summarize values in error messages - - #todo - allow defaults outside of choices/ranges - - #check types,ranges,choices - set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] - #set combined_defaults [tcl::dict::merge $VAL_DEFAULTS $OPT_DEFAULTS] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash - #puts "---opts_and_values:$opts_and_values" - #puts "---argstate:$argstate" - tcl::dict::for {argname v} $opts_and_values { - set thisarg [tcl::dict::get $argstate $argname] - #set thisarg_keys [tcl::dict::keys $thisarg] - set thisarg_checks [tcl::dict::get $arg_checks $argname] - set is_multiple [tcl::dict::get $thisarg -multiple] - set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] - set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] - set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] - set has_default [tcl::dict::exists $thisarg -default] - if {$has_default} { - set defaultval [tcl::dict::get $thisarg -default] - } - set type [tcl::dict::get $thisarg -type] - set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] - set regexprepass [tcl::dict::get $thisarg -regexprepass] - set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 - set validationtransform [tcl::dict::get $thisarg -validationtransform] - - - if {$is_multiple} { - set vlist $v - } else { - set vlist [list $v] - } - set vlist_original $vlist ;#retain for possible final strip_ansi - - #review - validationtransform - if {$is_validate_ansistripped} { - #validate_ansistripped 1 - package require punk::ansi - set vlist_check [list] - foreach e $vlist { - lappend vlist_check [punk::ansi::ansistrip $e] - } - } else { - #validate_ansistripped 0 - set vlist_check $vlist - } - - switch -- [Dict_getdef $thisarg -ARGTYPE unknown] { - leader { - set dname leaders_dict - set argclass "Leading argument" - } - option { - set dname opts - set argclass Option - } - value { - set dname values_dict - set argclass "Trailing argument" - } - default { - set dname "_unknown_" ;#NA - set argclass "Unknown argument" - } - } - #reduce our validation requirements by removing values which match defaultval or match -choices - #(could be -multiple with -choicerestriction 0 where some selections match and others don't) - if {$has_choices} { - #-choices must also work with -multiple - #todo -choicelabels - set choiceprefix [tcl::dict::get $thisarg -choiceprefix] - set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] - set choicerestricted [tcl::dict::get $thisarg -choicerestricted] - set choicemultiple [tcl::dict::get $thisarg -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set nocase [tcl::dict::get $thisarg -nocase] - set choices [Dict_getdef $thisarg -choices {}] - set choicegroups [Dict_getdef $thisarg -choicegroups {}] - set allchoices $choices - if {[dict size $choicegroups]} { - dict for {groupname groupmembers} $choicegroups { - lappend allchoices {*}$groupmembers - } - } - #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups - #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes - - - set idx 0 ;# - #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes - #assert llength $vlist == llength [dict get $dname $argname] - # (unless there was a default and the option wasn't specified) - set vlist_validate [list] - set vlist_check_validate [list] - foreach e $vlist e_check $vlist_check { - set allchoices_in_list 0 - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - #vlist and vlist_check can be list of lists if -multiple and -choicemultiple - #each e represents 0 or more choice selections - set c_list $e - set c_check_list $e_check - #todo? check if entire list matches default? - } else { - #only one choice at a time - ensure single entry in c_list c_check_list - set c_list [list $e] - set c_check_list [list $e_check] - } - - - #----------------------------------- - #fast fail on the wrong number of choices - if {[llength $c_list] < $choicemultiple_min} { - set msg "$argclass $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { - set msg "$argclass $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - #----------------------------------- - - set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list - foreach c $c_list c_check $c_check_list { - if {$nocase} { - set casemsg " (case insensitive)" - set choices_test [tcl::string::tolower $allchoices] - #Don't lcase the denylist - even in nocase mode! - #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] - set v_test [tcl::string::tolower $c_check] - } else { - set casemsg " (case sensitive)" - set v_test $c_check - set choices_test $allchoices - } - set choice_in_list 0 - set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? - if {!$matches_default} { - if {$choiceprefix} { - #can we handle empty string as a choice? It should just work - REVIEW/test - set choice_exact_match 0 - if {$c_check in $allchoices} { - #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing - set chosen $c_check - set choice_in_list 1 - set choice_exact_match 1 - } elseif {$v_test in $choices_test} { - #assert - if we're here, nocase must be true - #we know choice is present as full-length match except for case - #now we want to select the case from the choice list - not the supplied value - #we don't set choice_exact_match - because we will need to override the optimistic existing val below - #review - foreach avail [lsort -unique $allchoices] { - if {[string match -nocase $c $avail]} { - set chosen $avail - } - } - #assert chosen will always get set - set choice_in_list 1 - } else { - #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. - #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. - #in this block we can treat empty result from prefix match as a non-match - if {$nocase} { - #nocase implies that our entered value doesn't have to match case of choices - - #but we would still like to select the best match if there are case-dups. - #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete - # selecting Del will find Delete, del will match delete (and raise error) - # but DEL will also match delete rather than Delete - so again an error is raised. - #This is counterintuitive with -nocase - #This is probably such an edge case that best served with documentation as a feature-not-bug - #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? - #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. - - set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] - if {$bestmatch eq ""} { - set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] - #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing - set chosen [lsearch -inline -nocase $allchoices $chosen] - set choice_in_list [expr {$chosen ne ""}] - } else { - set chosen $bestmatch - set choice_in_list 1 - } - } else { - set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] - if {$chosen eq ""} { - set choice_in_list 0 - } else { - set choice_in_list 1 - } - } - #override choice_in_list if in deny list - #don't allow prefixing for elements from -choiceprefixdenylist - #we still use all elements to calculate the prefixes though - #review - case difference edge cases in choiceprefixdenylist !todo - if {$chosen in $choiceprefixdenylist} { - set choice_in_list 0 - set chosen "" - } - } - - #override the optimistic existing val - if {$choice_in_list && !$choice_exact_match} { - if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { - if {$is_multiple} { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $idx $chosen - tcl::dict::set $dname $argname $existing - } else { - tcl::dict::set $dname $argname $chosen - } - } else { - if {$is_multiple} { - set existing_all [tcl::dict::get [set $dname] $argname] - lset existing_all $idx $choice_idx $chosen - tcl::dict::set $dname $argname $existing_all - } else { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $choice_idx $chosen - tcl::dict::set $dname $argname $existing - } - } - } - } else { - #value as stored in $dname is ok - set choice_in_list [expr {$v_test in $choices_test}] - } - } - - if {!$choice_in_list && !$matches_default} { - if {!$choicerestricted} { - #if {$is_multiple} { - # set existing [tcl::dict::get [set $dname] $argname] - # lset existing $idx $v_test - # tcl::dict::set $dname $argname $existing - #} else { - # tcl::dict::set $dname $argname $v_test - #} - lappend vlist_validate $c - lappend vlist_check_validate $c_check - } else { - #unhappy path - if {$choiceprefix} { - set prefixmsg " (or a unique prefix of a value)" - } else { - set prefixmsg "" - } - #review: $c vs $c_check for -badval? - set msg "$argclass '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname - } - } - incr choice_idx - } - - incr idx - } - #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation - #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - - if {[llength $vlist] && $has_default} { - set vlist_validate [list] - set vlist_check_validate [list] - foreach c $vlist c_check $vlist_check { - #for -choicemultiple with default that could be a list use 'ni' ?? review - if {$c_check ne $defaultval} { - lappend vlist_validate $c - lappend vlist_check_validate $c - } - } - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - - #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups - #assert: our vlist & vlist_check lists have been reduced to remove those - if {[llength $vlist] && !$is_allow_ansi} { - #allow_ansi 0 - package require punk::ansi - #do not run ta::detect on a list - foreach e $vlist { - if {[punk::ansi::ta::detect $e]} { - set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - #puts "argname:$argname v:$v is_default:$is_default" - #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. - #arguments that are at their default are not subject to type and other checks - - #don't validate defaults or choices that matched - #puts "---> opts_and_values: $opts_and_values" - #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" - #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} - - #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups - #assert [llength $vlist] == [llength $vlist_check] - if {[llength $vlist]} { - switch -- $type { - literal { - foreach e $vlist { - if {$e ne $argname} { - set msg "$argclass '$argname' for %caller% requires literal value '$argname'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - } - } - } - any {} - list { - foreach e_check $vlist_check { - if {![tcl::string::is list -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[llength $e_check] < $checkval} { - set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[llength $e_check] > $checkval} { - set msg "$argclass '$argname for %caller% requires list with -maxsize $checkval. Received len:[llength $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - } - indexexpression { - foreach e_check $vlist_check { - if {[catch {lindex {} $e_check}]} { - set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - string - ansistring - globstring { - #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string - #we possibly don't want to always have to regex on things that don't pass the other more basic checks - # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) - # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) - # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead - # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function - # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) - # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail - - #todo? - way to validate both unstripped and stripped? - set pass_quick_list_e [list] - set pass_quick_list_e_check [list] - set remaining_e $vlist - set remaining_e_check $vlist_check - #review - order of -regexprepass and -regexprefail in original rawargs significant? - #for now -regexprepass always takes precedence - if {$regexprepass ne ""} { - foreach e $vlist e_check $vlist_check { - if {[regexp $regexprepass $e]} { - lappend pass_quick_list_e $e - lappend pass_quick_list_e_check $e_check - } - } - set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] - set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] - } - if {$regexprefail ne ""} { - foreach e $remaining_e e_check $remaining_e_check { - #puts "----> checking $e vs regex $regexprefail" - if {[regexp $regexprefail $e]} { - if {[tcl::dict::exists $thisarg -regexprefailmsg]} { - #review - %caller% ?? - set msg [tcl::dict::get $thisarg -regexprefailmsg] - } else { - set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" - } - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $e -argspecs $argspecs]] $msg - } - } - } - switch -- $type { - ansistring { - #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi - #.. so we need to look at the original values in $vlist not $vlist_check - - #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? - #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? - package require punk::ansi - foreach e $remaining_e { - if {![punk::ansi::ta::detect $e]} { - set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - } - } - } - globstring { - foreach e $remaining_e { - if {![regexp {[*?\[\]]} $e]} { - set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - } - } - } - } - - if {[tcl::dict::size $thisarg_checks]} { - foreach e_check $remaining_e_check { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[tcl::string::length $e_check] < $checkval} { - set msg "$argclass '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::string::length $e_check] > $checkval} { - set msg "$argclass '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - } - int { - #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive - if {[tcl::dict::exists $thisarg -range]} { - lassign [tcl::dict::get $thisarg -range] low high - if {"$low$high" ne ""} { - if {$low eq ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - #lowside unspecified - check only high - if {$e_check > $high} { - set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $hight. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } elseif {$high eq ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - #highside unspecified - check only low - if {$e_check < $low} { - set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } else { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - #high and low specified - if {$e_check < $low || $e_check > $high} { - set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } else { - foreach e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - double { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is double -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type double. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - if {[tcl::dict::size $thisarg_checks]} { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -range { - #todo - small-value double comparisons with error-margin? review - #todo - empty string for low or high - lassign $checkval low high - if {$e_check < $low || $e_check > $high} { - set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - bool { - foreach e_check $vlist_check { - if {![tcl::string::is boolean -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - dict { - foreach e_check $vlist_check { - if {[llength $e_check] %2 != 0} { - set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[tcl::dict::size $e_check] < $checkval} { - set msg "$argclass '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::dict::size $e_check] > $checkval} { - set msg "$argclass '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - } - alnum - - alpha - - ascii - - control - - digit - - graph - - lower - - print - - punct - - space - - upper - - wordchar - - xdigit { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is $type $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - file - - directory - - existingfile - - existingdirectory { - foreach e $vlist e_check $vlist_check { - #//review - we may need '?' char on windows - if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { - #what about special file names e.g on windows NUL ? - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - if {$type eq "existingfile"} { - foreach e $vlist e_check $vlist_check { - if {![file exists $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } elseif {$type eq "existingdirectory"} { - foreach e $vlist e_check $vlist_check { - if {![file isdirectory $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } - } - char { - #review - char vs unicode codepoint vs grapheme? - foreach e $vlist e_check $vlist_check { - if {[tcl::string::length $e_check] != 1} { - set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } - } - - } - - if {$is_strip_ansi} { - set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach - if {[tcl::dict::get $thisarg -multiple]} { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict $argname $stripped_list - } - option { - tcl::dict::set opts $argname $stripped_list - } - value { - tcl::dict::set values_dict $argname $stripped_list - } - } - } else { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict [lindex $stripped_list 0] - } - option { - tcl::dict::set opts $argname [lindex $stripped_list 0] - } - value { - tcl::dict::set values_dict [lindex $stripped_list 0] - } - } - } - } - } - - #maintain order of opts $opts values $values as caller may use lassign. - set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] - if {[llength $receivednames]} { - #flat zip of names with overall posn, including opts - #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] - set i -1 - set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] - } else { - set received_posns [list] - } - #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) - #(e.g using 'dict exists $received -flag') - # - but it can have duplicate keys when args/opts have -multiple 1 - #It is actually a list of paired elements - return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived multis $multisreceived] - } - - - proc forms {id} { - set spec [get_spec $id] - if {[dict size $spec]} { - return [dict get $spec form_names] - } else { - return [list] - } - } - lappend PUNKARGS [list { - @id -id ::punk::args::synopsis - @cmd -name punk::args::synopsis -help\ - "Return synopsis for each form of a command id - on separate lines. - If -form is given, supply only - the synopsis for that form. - " - @opts - -form -type string -default * - -return -type string -default full -choices {full summary dict} - @values -min 1 -max -1 - cmditem -multiple 1 -optional 0 - }] - proc synopsis {args} { - set argd [punk::args::parse $args withid ::punk::args::synopsis] - - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - if {$has_punkansi} { - set I [punk::ansi::a+ italic] - set RST [punk::ansi::a] - } else { - set I "" - set RST "" - } - - ##set form * - ##if {[lindex $args 0] eq "-form"} { - ## set arglist [lrange $args 2 end] - ## set form [lindex $args 1] - ##} else { - ## set arglist $args - ##} - ##if {[llength $arglist] == 0} { - ## error "punk::args::synopsis expected command id possibly with trailing subcommands/args" - ##} - ##set id [lindex $arglist 0] - ##set cmdargs [lrange $arglist 1 end] - - lassign [dict values $argd] leaders opts values - set form [dict get $opts -form] - set opt_return [dict get $opts -return] - set cmditems [dict get $values cmditem] - set id [lindex $cmditems 0] - set cmdargs [lrange $cmditems 1 end] - - - set spec [get_spec $id] - if {$spec eq ""} { - return - } - set form_names [dict get $spec form_names] - if {$form ne "*"} { - if {[string is integer -strict $form]} { - set f [lindex $form_names $form] - if {$f ne ""} { - set form_names [list $f] - } else { - set form_names [list] - } - } else { - if {$form in $form_names} { - set form_names [list $form] - } else { - set form_names [list] - } - } - } - - set SYND [dict create] - set syn "" - #todo - -multiple etc - foreach f $form_names { - set SYNLIST [list] - dict set SYND $f [list] - append syn "$id" - set forminfo [dict get $spec FORMS $f] - foreach argname [dict get $forminfo LEADER_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set ARGD [dict create argname $argname class leader] - if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - set display [lindex [dict get $arginfo -choices] 0] - } elseif {[dict get $arginfo -type] eq "literal"} { - set display $argname - } else { - set display $I$argname$RST - } - if {[dict get $arginfo -optional]} { - append syn " ?$display?" - } else { - append syn " $display" - } - dict set ARGD type [dict get $arginfo -type] - dict set ARGD optional [dict get $arginfo -optional] - dict set ARGD display $display - dict lappend SYND $f $ARGD - } - foreach argname [dict get $forminfo OPT_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set ARGD [dict create argname $argname class option] - set tp [dict get $arginfo -type] - if {[dict get $arginfo -optional]} { - if {[dict get $arginfo -multiple]} { - if {$tp eq "none"} { - set display "?$argname?..." - } else { - set display "?$argname <$tp>?..." - } - } else { - if {$tp eq "none"} { - set display "?$argname?" - } else { - set display "?$argname <$tp>?" - } - } - } else { - if {[dict get $arginfo -multiple]} { - if {$tp eq "none"} { - set display "$argname ?$argname...?" - } else { - set display "$argname <$tp> ?$argname <$tp>?..." - } - } else { - if {$tp eq "none"} { - set display $argname - } else { - set display "$argname <$tp>" - } - } - } - append syn " $display" - dict set ARGD type [dict get $arginfo -type] - dict set ARGD optional [dict get $arginfo -optional] - dict set ARGD display $display - dict lappend SYND $f $ARGD - } - foreach argname [dict get $forminfo VAL_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set ARGD [dict create argname $argname class value] - if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} { - if {[dict get $arginfo -multiple]} { - set display "?$I$argname$RST?..." - } else { - if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - set display "?[lindex [dict get $arginfo -choices] 0]?" - } elseif {[dict get $arginfo -type] eq "literal"} { - set display "?$argname?" - } else { - set display "?$I$argname$RST?" - } - } - } else { - if {[dict get $arginfo -multiple]} { - set display "$I$argname$RST ?$I$argname$RST?..." - } else { - if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - set display "[lindex [dict get $arginfo -choices] 0]" - } elseif {[dict get $arginfo -type] eq "literal"} { - set display $argname - } else { - set display "$I$argname$RST" - } - } - } - append syn " $display" - dict set ARGD type [dict get $arginfo -type] - dict set ARGD optional [dict get $arginfo -optional] - dict set ARGD display $display - dict lappend SYND $f $ARGD - } - append syn \n - } - switch -- $opt_return { - full { - return [string trim $syn \n] - } - summary { - set summary "" - dict for {form arglist} $SYND { - append summary $id - set class_state leader - set option_count 0 - set value_count 0 - foreach ainfo $arglist { - switch -- [dict get $ainfo class] { - leader { - append summary " [dict get $ainfo display]" - } - option { - incr option_count - } - value { - incr value_count - if {$class_state ne "value"} { - if {$option_count > 0} { - append summary " ?options ($option_count defined)?" - } - set class_state value - } - append summary " [dict get $ainfo display]" - } - } - } - if {$value_count == 0 && $option_count > 0} { - append summary " ?options ($option_count defined)?" - } - append summary \n - } - set summary [string trim $summary \n] - return $summary - } - dict { - return $SYND - } - } - } - - - lappend PUNKARGS [list { - @id -id ::punk::args::synopsis_summary - @cmd -name punk::args::synopsis_summary -help\ - "Reduce the width of a synopsis string - by coalescing options to ?options?... - synopsis string may be arbitrarily marked - up with ANSI codes." - @opts - @values -min 1 -max -1 - synopsis -multiple 0 -optional 0 - }] - proc synopsis_summary {args} { - set argd [punk::args::parse $args withid ::punk::args::synopsis_summary] - set synopsis [dict get $argd values synopsis] - set summary "" - foreach sline [split $synopsis \n] { - set sline [regsub -all {\s+} $sline " "] ;#normalize to single spacing only - review - set in_opt 0 - set line_out "" - set codestack [list] - set parts [punk::ansi::ta::split_codes_single $sline] - #basic - foreach {pt code} $parts { - set charlist [split $pt ""] - for {set i 0} {$i < [llength $charlist]} {incr i} { - set c [lindex $charlist $i] - - switch -- $c { - ? { - if {!$in_opt} { - set in_opt 1 - } else { - - } - } - " " { - if {!$in_opt} { - append line_out " " - } else { - set in_opt - } - } - default { - if {!$in_opt} { - append line_out $c - } - } - } - } - if {$code ne ""} { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set codestack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set codestack [list $code] - } elseif {[punk::ansi::codetype::is_sgr $code]} { - #basic simplification first - remove straight dupes - set dup_posns [lsearch -all -exact $codestack $code] ;#must be -exact because of square-bracket glob chars - set codestack [lremove $codestack {*}$dup_posns] - lappend codestack $code - } else { - #? ignore other ANSI codes? - } - } - } - if {[string match -* $plain_s] || [string match ?- $plain_s]} { - } - } - return $summary - } - - lappend PUNKARGS [list { - @id -id ::punk::args::TEST - @opts -optional 0 - -o1 -default 111 -help "opt 1 mandatory" - @opts -optional 1 - -o2 -default 222 -help "opt 2 optional" - @values -min 0 -max 1 - v -help\ - "v1 optional" - }] - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::lib { - variable PUNKARGS - tcl::namespace::export * - tcl::namespace::path [list [tcl::namespace::parent]] - #*** !doctools - #[subsection {Namespace punk::args::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 flatzip {l1 l2} { - concat {*}[lmap a $l1 b $l2 {list $a $b}] - } - - if {[info commands lseq] ne ""} { - #tcl 8.7+ lseq significantly faster, especially for larger ranges - #The internal rep can be an 'arithseries' with no string representation - proc zero_based_posns {count} { - if {$count < 1} {return} - lseq 0 $count-1 - } - } else { - proc zero_based_posns {count} { - if {$count < 1} {return} - lsearch -all [lrepeat $count 0] * - } - } - - #return list of single column-width marks - possibly with ansi - proc choiceinfo_marks {choice choiceinfodict} { - set marks [list] - if {[dict exists $choiceinfodict $choice]} { - set cinfo [dict get $choiceinfodict $choice] - foreach info $cinfo { - if {[lindex $info 0] eq "doctype"} { - switch -- [lindex $info 1] { - punkargs { - lappend marks [punk::ns::Cmark punkargs brightgreen] - } - ensemble { - lappend marks [punk::ns::Cmark ensemble brightyellow] - } - oo { - lappend marks [punk::ns::Cmark oo brightcyan] - } - ooc { - lappend marks [punk::ns::Cmark ooc cyan] - } - ooo { - lappend marks [punk::ns::Cmark ooo cyan] - } - native { - lappend marks [punk::ns::Cmark native] - } - unknown { - lappend marks [punk::ns::Cmark unknown brightred] - } - } - } - } - } - return $marks - } - - - #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 -1] in calling scope ${[lindex [set x] 0]} !} - lappend PUNKARGS [list { - @id -id ::punk::args::lib::tstr - @cmd -name punk::args::lib::tstr -help\ - "A rough equivalent of js template literals - - Substitutions: - \$\{$varName\} - \$\{[myCommand]\} - (when -allowcommands flag is given)" - -allowcommands -default 0 -type none -help\ - "If -allowcommands is present, placeholder can contain commands - e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" - -undent -default 1 -type boolean -help\ - "undent/dedent the template lines. - The longest common prefix of whitespace is removed" - -indent -default "" -type string -help\ - "String with which to indent the template - prior to substitution. - If -undent is enabled, that is performed - first, then the indent is applied." - -paramindents -default line -choices {none line position} -choicelabels { - line\ - " Use leading whitespace in - the line in which the - placeholder occurs." - position\ - " Use the position in - the line in which the - placeholder occurs." - none\ - " No indents applied to - subsequent placeholder value - lines. This will usually - result in text awkwardly - ragged unless the source code - has also been aligned with the - left margin or the value has - been manually padded." - } -help\ - "How indenting is done for subsequent lines in a - multi-line placeholder substitution value. - The 1st line or a single line value is always - placed at the placeholder. - paramindents are performed after the main - template has been indented/undented. - (indenting by position does not calculate - unicode double-wide or grapheme cluster widths) - " - #choicelabels indented by 1 char is clearer for -return string - and reasonable in table - -return -default string -choices {dict list string args}\ - -choicelabels { - dict\ - " Return a dict with keys - 'template', 'params' and - 'errors'" - string\ - " Return a single result - being the string with - placeholders substituted." - list\ - " Return a 2 element list. - The first is itself a list - of plaintext portions of the - template, split at each point - at which placeholders were - present. The second element - of the outer list is a list - of placeholder values if -eval - is 1, or a list of the raw - placeholder strings if -eval - is 0." - args\ - " Return a list where the first - element is a list of template - plaintext sections as per the - 'list' return mechanism, but the - placeholder items are individual - items in the returned list. - This can be useful when passing - the expanded result of a tstr - command to another function - which expects the placeholders - as individual arguments" - } - -eval -default 1 -type boolean -help\ - "Whether to evaluate the \$\{\} placeholders. - When -return is string, -eval should generally be set to 1. - For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. - contained variables in that case should be braced or whitespace separated, or the variable - name is likely to collide with surrounding text. - e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" - @values -min 0 -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 - e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} - - Escape sequences such as \\n and unicode escapes are processed within placeholders. - " - }] - - proc tstr {args} { - #Too hard to fully eat-our-own-dogfood from within punk::args package - # - we use punk::args within the unhappy path only - #set argd [punk::args::get_by_id ::punk::lib::tstr $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 opt_eval [dict get $argd opts -eval] - - set templatestring [lindex $args end] - set arglist [lrange $args 0 end-1] - set opts [dict create\ - -allowcommands 0\ - -undent 1\ - -indent ""\ - -paramindents line\ - -eval 1\ - -return string\ - ] - if {"-allowcommands" in $arglist} { - set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] - dict set opts -allowcommands 1 - } - if {[llength $arglist] % 2 != 0} { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr expected option/value pairs prior to last argument" - } - } - dict for {k v} $arglist { - set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] - switch -- $fullk { - -indent - -undent - -paramindents - -return - -eval { - dict set opts $fullk $v - } - default { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" - } - } - } - } - set opt_allowcommands [dict get $opts -allowcommands] - set opt_paramindents [dict get $opts -paramindents] - set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] - if {$test_paramindents ni {none line position}} { - error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." - } - set opt_paramindents $test_paramindents - set opt_return [dict get $opts -return] - set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] - if {$opt_return eq ""} { - } - set opt_eval [dict get $opts -eval] - - - set nocommands "-nocommands" - if {$opt_allowcommands == 1} { - set nocommands "" - } - - set opt_undent [dict get $opts -undent] - if {$opt_undent} { - set templatestring [punk::args::lib::undent $templatestring] - } - set opt_indent [dict get $opts -indent] - if {$opt_indent ne ""} { - set templatestring [punk::args::lib::indent $templatestring $opt_indent] - } - - #set parts [_tstr_split $templatestring] - if {[string first \$\{ $templatestring] < 0} { - set parts [list $templatestring] - } else { - set parts [_parse_tstr_parts $templatestring] - } - set textchunks [list] - #set expressions [list] - set params [list] - set idx 0 - set errors [dict create] - set lastline "" ;#todo - first line has placeholder? - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach {pt expression} $parts { - lappend textchunks $pt - incr idx ;#pt incr - - #ignore last expression - if {$idx == [llength $parts]} { - break - } - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - #lappend expressions $expression - #---------------------- - #REVIEW - JMN - #TODO - debug punk::args loading of @dynamic defs - #puts "-- $expression" - #---------------------- - #brk1 - literal newline not {\n} - set leader "" - if {[set brk1 [string first \n $expression]] >= 0} { - #undent left of paramstart only for lines of expression that arent on opening ${..} line - set tail [string range $expression $brk1+1 end] - set leader [string repeat " " [string length $lastline]] - set undentedtail [punk::args::lib::undentleader $tail $leader] - #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] - set expression "[string range $expression 0 $brk1]$undentedtail" - } - if {$opt_eval} { - if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { - lappend params [string cat \$\{ $expression \}] - dict set errors [expr {[llength $params]-1}] $result - } else { - set result [string map [list \n "\n$leader"] $result] - lappend params $result - } - #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] - } else { - lappend params [subst -nocommands -novariables $expression] - } - append lastline [lindex $params end] ;#for current expression's position calc - - incr idx ;#expression incr - } - - if {$opt_return eq "dict"} { - return [dict create template $textchunks params $params errors $errors] - } - if {[dict size $errors]} { - set einfo "" - dict for {i e} $errors { - append einfo "parameter $i error: $e" \n - } - #REVIEW!!! - #TODO - fix - #puts stderr "tstr errors:\n$einfo\n" - } - - switch -- $opt_return { - list { - return [list $textchunks $params] - } - args { - #see example in tstr_test_one - return [list $textchunks {*}$params] - } - string { - #todo - flag to disable indent-matching behaviour for multiline param? - set out "" - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach pt $textchunks param $params { - if {$opt_paramindents eq "none"} { - append out $pt $param - } else { - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - if {$opt_paramindents eq "line"} { - regexp {(\s*).*} $lastline _all lastindent - } else { - #position - #TODO - detect if there are grapheme clusters - #This regsub doesn't properly space unicode double-wide chars or clusters - set lastindent "[regsub -all {\S} $lastline " "] " - } - if {$lastindent ne ""} { - set paramlines [split $param \n] - if {[llength $paramlines] == 1} { - append out $pt $param - } else { - append out $pt [lindex $paramlines 0] - foreach nextline [lrange $paramlines 1 end] { - append out \n $lastindent $nextline - } - } - } else { - append out $pt $param - } - append lastline $param - } - } - return $out - } - } - } - #test single placeholder tstr args where single placeholder must be an int - proc tstr_test_one {args} { - set argd [punk::args::parse $args withdef { - @cmd -name ::punk::args::lib::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 -return args {Select * from table where id = \$\{$id\} and etc... ;}] - } - - @values -min 2 -max 2 - template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - - but the tstr call in the example 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} - }] - 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]] ""] - set result [string cat [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 dollar sign - 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]] - } - - #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. - proc indent {text {prefix " "}} { - set result [list] - foreach line [split $text \n] { - if {[string trim $line] eq ""} { - lappend result "" - } else { - lappend result $prefix[string trimright $line] - } - } - return [join $result \n] - } - #dedent? - proc undent {text} { - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - regexp {^([\t ]*)} $lcp _m lcp - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - - #hacky - proc undentleader {text leader} { - #leader usually whitespace - but doesn't have to be - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - lappend nonblank "${leader}!!" - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - #regexp {^([\t ]*)} $lcp _m lcp - #lcp can be shorter than leader - set lcp [string range $lcp 0 [string length $leader]-1] - - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - #A version of textutil::string::longestCommonPrefixList - proc longestCommonPrefix {items} { - if {[llength $items] <= 1} { - return [lindex $items 0] - } - set items [lsort $items[unset items]] - set min [lindex $items 0] - set max [lindex $items end] - #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) - #(sort order nothing to do with length - e.g min may be longer than max) - if {[string length $min] > [string length $max]} { - set temp $min - set min $max - set max $temp - } - set n [string length $min] - set prefix "" - set i -1 - while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { - append prefix $c - } - return $prefix - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] -} - -tcl::namespace::eval punk::args::argdocbase { - namespace export * - #use a? to test and create literal ansi here rather than relying on punk::ansi package presence - #e.g - #% a? bold - #- bold │SGR 1│sample│␛[1msample - #- ──────┼─────┼──────┼────────── - #- RESULT│ │sample│␛[1msample - proc B {} {return \x1b\[1m} ;#a+ bold - proc N {} {return \x1b\[22m} ;#a+ normal - proc I {} {return \x1b\[3m} ;#a+ italic - proc NI {} {return \x1b\[23m} ;#a+ noitalic - -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::package { - variable PUNKARGS - lappend PUNKARGS [list { - @dynamic - @id -id "::punk::args::package::standard_about" - @cmd -name "%pkg%::about" -help\ - "About %pkg% - ... - " - -package_about_namespace -type string -optional 0 -help\ - "Namespace containing the package about procedures - Must contain " - -return\ - -type string\ - -default table\ - -choices {string table tableobject}\ - -choicelabels { - string\ - "A basic text layout" - table\ - "layout in table borders - (requires package: textblock)" - tableobject\ - "textblock::class::table object instance" - }\ - -help\ - "Choose the return type of the 'about' information" - topic -optional 1\ - -nocase 1\ - -default {*}\ - -choices {Description License Version Contact *}\ - -choicerestricted 0\ - -choicelabels { - - }\ - -multiple 1\ - -help\ - "Topic to display. Omit or specify as * to see all. - If * is included with explicit topics, * represents - the remaining unmentioned topics." - }] - proc standard_about {args} { - set argd [punk::args::parse $args withid ::punk::args::package::standard_about] - lassign [dict values $argd] leaders OPTS values received - - set pkgns [dict get $OPTS -package_about_namespace] - if {[info commands ${pkgns}::package_name] eq ""} { - error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" - } - set pkgname [${pkgns}::package_name] - - set opt_return [dict get $OPTS -return] - set all_topics [${pkgns}::about_topics] - if {![dict exists $received topic]} { - set topics $all_topics - } else { - # * represents all remaining topics not explicitly mentioned. - set val_topics [dict get $values topic] ;#if -multiple is true, this is a list - set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] - set topics [list] - foreach t $val_topics { - if {$t eq "*"} { - foreach a $all_topics { - if {$a ni $explicit_topics} { - lappend topics $a - } - } - } else { - lappend topics $t - } - } - } - if {$opt_return ne "string"} { - package require textblock ;#table support - set is_table 1 - set title [string cat {[} $pkgname {]} ] - set t [textblock::class::table new -title $title] - $t configure -frametype double -minwidth [expr {[string length $title]+2}] - - } else { - set topiclens [lmap t $topics {string length $t}] - set widest_topic [tcl::mathfunc::max {*}$topiclens] - set is_table 0 - set about "$pkgname\n" - append about [string repeat - $widest_topic] \n - } - foreach topic $topics { - if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { - set topic_contents [::${pkgns}::get_topic_$topic] - } else { - set topic_contents "" - } - if {!$is_table} { - set content_lines [split $topic_contents \n] - append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n - foreach ln [lrange $content_lines 1 end] { - append about [format %-${widest_topic}s ""] " " $ln \n - } - } else { - $t add_row [list $topic $topic_contents] - } - } - - if {!$is_table} { - return $about - } else { - if {$opt_return eq "tableobject"} { - return $t - } - set result [$t print] - $t destroy - return $result - } - } - -} - -#usually we would directly call arg definitions near the defining proc, -# so that the proc could directly use the definition in its parsing. -# -#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. -#arguably it may be more processor-cache-efficient to do together like this anyway. - -#can't do this here? - as there is circular dependency with punk::lib -#tcl::namespace::eval punk::args { -# foreach deflist $PUNKARGS { -# punk::args::define {*}$deflist -# } -# set PUNKARGS "" -#} - -lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -tcl::namespace::eval punk::args::system { - #*** !doctools - #[subsection {Namespace punk::args::system}] - #[para] Internal functions that are not part of the API - - #dict get value with default wrapper for tcl 8.6 - if {[info commands ::tcl::dict::getdef] eq ""} { - proc Dict_getdef {dictValue args} { - set keys [lrange $args 0 end-1] - if {[tcl::dict::exists $dictValue {*}$keys]} { - return [tcl::dict::get $dictValue {*}$keys] - } else { - return [lindex $args end] - } - } - } else { - #we pay a minor perf penalty for the wrap - interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef - } - - #name to reflect maintenance - home is punk::lib::ldiff - proc punklib_ldiff {fromlist removeitems} { - if {[llength $removeitems] == 0} {return $fromlist} - set result {} - foreach item $fromlist { - if {$item ni $removeitems} { - lappend result $item - } - } - return $result - } - -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::args [tcl::namespace::eval punk::args { - tcl::namespace::path {::punk::args::lib ::punk::args::system} - variable pkg punk::args - variable version - set version 0.1.6 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.7.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.7.tm deleted file mode 100644 index b04f4966..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.7.tm +++ /dev/null @@ -1,6458 +0,0 @@ -# -*- 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: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.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 punk::args 0.1.7 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.1.7] -#[copyright "2024"] -#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] -#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] -#[require punk::args] -#[keywords module proc args arguments parse] -#[description] -#[para]Utilities for parsing proc args - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). -#[para] overview of punk::args -#[subsection Concepts] -#[para]There are 2 main conventions for parsing a proc args list -#[list_begin enumerated] -#[enum] -#[para]leading option-value pairs and flags followed by a list of values (Tcl style) -#[enum] -#[para]leading list of values followed by option-value pairs and flags (Tk style) -#[list_end] -#[para]There are exceptions in both Tcl and Tk commands regarding this ordering -#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style -#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] -#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. -#[para] -#[para]The basic principle is that a call to punk::args::parse is made near the beginning of the proc with a cacheable argument defining the parameters e.g -#[example { -# proc dofilestuff {args} { -# lassign [dict values [punk::args::parse $args withdef { -# @cmd -help "do some stuff with files e.g dofilestuff " -# @opts -type string -# #comment lines ok -# -directory -default "" -# -translation -default binary -# #setting -type none indicates a flag that doesn't take a value (solo flag) -# -nocomplain -type none -# @values -min 1 -max -1 -# }]] leaders opts values -# -# puts "translation is [dict get $opts -translation]" -# foreach f [dict values $values] { -# puts "doing stuff with file: $f" -# } -# } -#}] -#[para]The lines beginning with @ are usually optional in most cases and can be used to set defaults and some extra controls -#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values -#[para]valid @ lines being with @cmd @leaders @opts @values -#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. -#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. -#[para]e.g the result from the punk::args::parse call above may be something like: -#[para] leaders {} opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} -#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments -#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments -#[para]This could also be implemented entirely using args - and the @leaders category of arguments -#[example { -# proc dofilestuff {category args} { -# lassign [dict values [punk::args::parse $args withdef { -# @id -id ::dofilestuff -# -directory -default "" -# -translation -default binary -# -nocomplain -type none -# @values -min 2 -max 2 -# fileA -type existingfile 1 -# fileB -type existingfile 1 -# }]] leaders opts values -# puts "$category fileA: [dict get $values fileA]" -# puts "$category fileB: [dict get $values fileB]" -# } -#}] -#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 -#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored -#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, -#[para] or an additional call could be made to punk::args e.g -#[example { -# punk::args::parse [list $category $another_leading_arg] withdef { -# category -choices {cat1 cat2 cat3} -# another_leading_arg -type boolean -# } -#}] - -#*** !doctools -#[subsection Notes] -#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. -#[para] -#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. -#For functions that are part of an API a package may be more suitable. -#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) -#[example { -# proc test_switch {args} { -# set opts [dict create\\ -# -return "object"\\ -# -frametype "heavy"\\ -# -show_edge 1\\ -# -show_seps 0\\ -# -x a\\ -# -y b\\ -# -z c\\ -# -1 1\\ -# -2 2\\ -# -3 3\\ -# ] -# foreach {k v} $args { -# switch -- $k { -# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { -# dict set opts $k $v -# } -# default { -# error "unrecognised option '$k'. Known options [dict keys $opts]" -# } -# } -# } -# return $opts -# } -#}] -#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. -#[para] -# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. -# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. -#[para]use punk::lib::show_jump_tables to verify that a jump table exists. -#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous -#[example { -# proc test_prefix {args} { -# set opts [dict create\ -# -return string\ -# -frametype \uFFEF\ -# -show_edge \uFFEF\ -# -show_seps \uFFEF\ -# -x a\ -# -y b\ -# -z c\ -# -1 1\ -# -2 2\ -# -3 3\ -# ] -# if {[llength $args]} { -# set knownflags [dict keys $opts] -# } -# foreach {k v} $args { -# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v -# } -# return $opts -# } -#}] -#[para]There are many alternative args parsing packages a few of which are listed here. -#[list_begin enumerated] -#[enum]argp (pure tcl) -#[enum]parse_args (c implementation) -#[enum]argparse (pure tcl *) -#[enum]cmdline (pure tcl) -#[enum]opt (pure tcl) distributed with Tcl but considered deprecated -#[enum]The tcllib set of TEPAM modules (pure tcl) -#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. -#[list_end] -#[para] (* c implementation planned/proposed) -#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. -#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences -#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. -#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. -#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. -#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. -#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -#All ensemble commands are slower in a safe interp as they aren't compiled the same way -#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 -#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. -#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) -#ensembles: array binary clock dict info namespace string -#possibly file too, although that is generally hidden/modified in a safe interp -#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc -#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::args -#[list_begin itemized] -package require Tcl 8.6- -#optional? punk::trie -#optional? punk::textblock -#*** !doctools -#[item] [package {Tcl 8.6-}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -tcl::namespace::eval punk::args::register { - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] cooperative namespace punk::args::register - #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded - #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. - #[list_begin definitions] - - #Although the actual punk::args::define calls are not too sluggish, there could be *many*. - #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, - #especially since a fair proportion may be for documentation purposes rather than parsing args. - - # -- --- --- --- --- --- --- --- - #cooperative with packages that define some punk args but do so lazily - #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first - variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective - if {![info exists ::punk::args::register::NAMESPACES]} { - set ::punk::args::register::NAMESPACES [list] - } - # -- --- --- --- --- --- --- --- - - variable loaded_packages - if {![info exists loaded_packages]} { - set loaded_packages [list] ;#fully loaded - } - variable loaded_info - if {![info exists loaded_info]} { - set loaded_info [dict create] ;#time - } - variable scanned_packages - if {![info exists scanned_packages]} { - set scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages - } - variable scanned_info ;#time and idcount - if {![info exists scanned_info]} { - set scanned_info [dict create] - } - #some packages, e.g punk::args::tclcore document other namespaces. - #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources - variable namespace_docpackages - if {![info exists namespace_docpackages]} { - set namespace_docpackages [dict create] - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::register ---}] -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args { - - - variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. - - tcl::namespace::export {[a-z]*} - variable rawdef_cache - if {![info exists rawdef_cache]} { - set rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} - } - variable id_cache_rawdef - if {![info exists id_cache_rawdef]} { - set id_cache_rawdef [tcl::dict::create] - } - variable id_cache_spec - if {![info exists id_cache_spec]} { - set id_cache_spec [tcl::dict::create] - } - - variable argdefcache_unresolved - if {![info exists argdefcache_unresolved]} { - set argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) - } - - variable argdata_cache - if {![info exists argdata_cache]} { - set argdata_cache [tcl::dict::create] - } - - variable id_counter - if {![info exists id_counter]} { - set id_counter 0 - } - - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] Core API functions for punk::args - #[list_begin definitions] - - #todo - some sort of punk::args::cherrypick operation to get spec from an existing set - #todo - doctools output from definition - - - - - #todo? -synonym/alias ? (applies to opts only not values) - #e.g -background -aliases {-bg} -default White - #review - how to make work with trie prefix - #e.g - # -corner -aliases {-corners} - # -centre -aliases {-center -middle} - #We mightn't want the prefix to be longer just because of an alias - #we should get -co -ce and -m from the above as abbreviations - - set map [list %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] - - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::define - #todo @preamble -help "move large block outside of table?" - @cmd -name punk::args::define -help\ - "Accepts a line-based definition of command arguments. - The definition can be supplied as a single text block or multiple as described - in the help information for 'text' below. - - Returns an id which is a key to the stored definition. - The id is taken from the supplied definition's @id -id line, or is an - automatically created id of the form 'autoid_'. - - At the time define is called - just the raw text arguments are stored for the id. - When the id is first used, for example with 'punk::args::parse $args withid $id', - the raw definition is parsed into a stored specifications dictionary. - - This specifications dictionary is structured for (optional) use within commands to - parse and validate the arguments - and is also used when retrieving definitions - (or parts thereof) for re-use. - - This can be used purely for documentation or called within a function to parse a mix - of leading values, switches/flags and trailing values. - - The overhead is favourably comparable with other argument processors - but none are - as fast as minimal code with a switch statement. For toplevel commands where a few - 10s of microseconds is immaterial, the validation and automated error formatting in - a table can be well worthwhile. For inner procs requiring utmost speed, the call can - be made only on the unhappy path when basic processing determines a mismatch - or it - can be left entirely as documentation for interactive use with: i ... - and for synopsis generation with: s ... - - The definition should usually contain an initial line of the form: @id -id ::somecmd - - Blank lines are ignored at the top level, ie if they are not part of another structure. - Similarly - lines at the top level beginning with the # character are ignored. - All other toplevel lines must consist of a leading word followed by paired arguments. - The arguments can be spread over multiple lines and contain lines of near-arbitrary - text if they are properly braced or double quoted and Tcl escaping for inner quotes - or unbalanced braces is maintained. - The line continuation character - (\\ at the end of the line) can be used to continue the set of arguments for - a leading word. - Leading words beginning with the @ character are directives controlling argument - parsing, defaults for subsequent arguments, and help display. - directives include: - %B%@id%N% ?opt val...? - directive-options: -id - %B%@cmd%N% ?opt val...? - directive-options: -name -help - %B%@leaders%N% ?opt val...? - directive-options: -min -max - (used for leading args that come before switches/opts) - %B%@opts%N% ?opt val...? - directive-options: -any - %B%@values%N% ?opt val...? - directive-options: -min -max - (used for trailing args that come after switches/opts) - %B%@form%N% ?opt val...? - directive-options: -form -synopsis - (used for commands with multiple forms) - The -synopsis value allows overriding the auto-calculated - synopsis. - %B%@formdisplay%N% ?opt val...? - directive-options: -header (text for header row of table) - -body (override autogenerated arg info for form) - %B%@doc%N% ?opt val...? - directive-options: -name -url - %B%@seealso%N% ?opt val...? - directive-options: -name -url (for footer - unimplemented) - - Some other options normally present on custom arguments are available - to use with the @leaders @opts @values directives to set defaults - for subsequent lines that represent your custom arguments. - These 3 directives should occur in exactly this order - but can be - repeated with custom argument lines interspersed. - - An @id line can only appear once and should be the first item. - For the commandline usage to be displayed either on parsing error - or using the i .. function - an @id with -id is needed. - - All directives can be omitted, in which case every line represents - a custom leader, value or option. - All will be leaders by default if no options defined. - If options are defined (by naming with leading dash, or explicitly - specifying @opts) then the definitions prior to the options will be - categorised as leaders, and those following the options will be - categorised as values. - - Custom arguments are defined by using any word at the start of a - line that doesn't begin with @ or - - (except that adding an additionl @ escapes this restriction so - that @@somearg becomes an argument named @somearg) - - custom leading args, switches/options (names starting with -) - and trailing values also take spec-options: - - -type - defaults to string. If no other restrictions - are specified, choosing string does the least validation. - recognised types: - none - (used for switches only. Indicates this is - a 'solo' flag ie accepts no value) - int|integer - list - indexexpression - dict - double - bool|boolean - char - file - directory - string - ansistring - globstring - (any of the types accepted by 'string is') - - These all perform some validation checks - - and more.. (todo - document here) - - -optional - (defaults to true for flags/switches false otherwise) - For non flag/switch arguments - all arguments with - -optional true must sit consecutively within their group. - ie all optional leader arguments must be together, and all - optional value arguments must be together. Furthermore, - specifying both optional leaders and optional values will - often lead to ambiguous parsing results. Currently, all - optional non-flg/switch arguments should be either at the - trailing end of leaders or the trailing end of values. - Further unambiguous arrangements of optional args may be - made in future - but are currently considered 'unsupported' - -default - -multiple (for leaders & values defines whether - subsequent received values are stored against the same - argument name - only applies to final leader OR final value) - (for options/flags this allows the opt-val pair or solo - flag to appear multiple times - not necessarily contiguously) - -choices {} - A list of allowable values for an argument. - The -default value doesn't have to be in the list. - If a -type is specified - it doesn't apply to choice members. - It will only be used for validation if the -choicerestricted - option is set to false. If all choices are specified in values - within the -choicegroups dict, it is not necessary to specify them - in the -choices list. It is effectively a simpler form of - specifying choices when no grouping is required. It is fine to - use both -choices and -choicegroups e.g specifying all in -choices - and then including only some that need grouping in -choicegroups. - -choicelabels {} - keys are the values/argument names from -choices (or equivalently - members of value entries from the -choicegroups dict) - The values in the choicelabels dict are text values, possibly - containing newlines, that are displayed below each choice. - This is commonly a very basic summary of the choice. In the - case of a subcommand it may be a usage synopsis for further - arguments. - -choicerestricted - Whether values not specified in -choices or -choicegroups are - allowed. Defaults to true. - -choiceprefix - This specifies whether unique prefixes are able to be used - instead of the complete string. This is calculated using - tcl::prefix::match - and will display in the autogenerated - usage output. Defaults to true. - -choiceprefixdenylist {} - These choices should match exactly a choice entry in one of - the settings -choices or -choicegroups. - These will still be used in prefix calculation - but the full - choice argument must be entered to select the choice. - -choicegroups {} - Generally this would be used instead of -choices to allow - usage display of choices grouped by some name (or the empty - string for 'ungrouped' items which appear first). - See for example the output if 'i zlib' where choices of the - next subcommand are grouped by the names compression,channel, - streaming and checksumming. The -choices list is equivalent - to a -choicegroups dict entry where the key (groupname) is - the empty string. Both may be specified, in which case the - final list of available choices will be a union of the listed - values in -choices and the values from each choice group. - Choice values specified in -choices are effectively ungrouped - unless overridden by placing them in a choicegroup. - -choicemultiple (default {1 1}) - is a pair representing min and max number of choices - that can be present in the value. - If is a single integer it is equivalent to a - specified with the same integer for both min and max. - Max of -1 represents no upper limit. - If allows more than one choice the value is a list - consisting of items in the choices made available through - entries in -choices/-choicegroups. - -minsize (type dependant) - -maxsize (type dependant) - -range (type dependant) - - - " - -dynamic -type boolean -default 0 -help\ - "If -dynamic is true, tstr interpolations of the form \$\{\$var\} - are re-evaluated on each call. - If the definition is being used not just as documentation, but is also - used within the function to parse args, e.g using punk::args::get_by_id, - then it should be noted that there is a slight performance penalty for the - dynamic case. - It is often not significant, perhaps depending on what vars/commands are - used but -dynamic true might be less desirable if the command is used in - inner loops in more performance-sensitive code. - " - @values -min 1 -max -1 - text -type string -multiple 1 -help\ - "Block(s) of text representing the argument definition for a command. - At least one must be supplied. If multiple, they are joined together with \\n. - Using multiple text arguments may be useful to mix curly-braced and double-quoted - strings to have finer control over interpolation when defining arguments. - (this can also be handy for sections that pull resolved definition lines - from existing definitions (by id) for re-use of argument specifications and help text) - - e.g the following definition passes 2 blocks as text arguments - definition { - @id -id ::myns::myfunc - @cmd -name myns::myfunc -help\\ - \"Description of command\" - - #The following option defines an option-value pair - -option1 -default blah -type string - #The following option defines a flag style option (solo) - -flag1 -default 0 -type none -help\\ - \"Info about flag1 - subsequent help lines auto-dedented by whitespace to left - of corresponding record start (in this case -flag1) - + first 4 spaces if they are all present. - This line has no extra indent relative to first line 'Info about flag1' - This line indented a further 6 chars\" - - @values -min 1 -max -1 - #Items that don't begin with * or - are value definitions - v1 -type integer -default 0 - thinglist -type string -multiple 1 - } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" - " - }]] - - proc New_command_form {name} { - #probably faster to inline a literal dict create in the proc than to use a namespace variable - set leaderspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - -ensembleparameter 0\ - ] - set optspec_defaults [tcl::dict::create\ - -type string\ - -optional 1\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - -prefix 1\ - ] - set valspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - - #form record can have running entries such as 'argspace' that aren't given to arg parser - #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict - return [dict create\ - argspace "leaders"\ - ARG_INFO [tcl::dict::create]\ - ARG_CHECKS [tcl::dict::create]\ - LEADER_DEFAULTS [tcl::dict::create]\ - LEADER_REQUIRED [list]\ - LEADER_NAMES [list]\ - LEADER_MIN ""\ - LEADER_MAX ""\ - LEADERSPEC_DEFAULTS $leaderspec_defaults\ - LEADER_CHECKS_DEFAULTS {}\ - OPT_DEFAULTS [tcl::dict::create]\ - OPT_REQUIRED [list]\ - OPT_NAMES [list]\ - OPT_ANY 0\ - OPT_SOLOS {}\ - OPTSPEC_DEFAULTS $optspec_defaults\ - OPT_CHECKS_DEFAULTS {}\ - VAL_DEFAULTS [tcl::dict::create]\ - VAL_REQUIRED [list]\ - VAL_NAMES [list]\ - VAL_MIN ""\ - VAL_MAX ""\ - VALSPEC_DEFAULTS $valspec_defaults\ - VAL_CHECKS_DEFAULTS {}\ - FORMDISPLAY [tcl::dict::create]\ - ] - - } - - proc errorstyle {args} { - #set or query the running config -errorstyle - #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? - #values: - #debug, enhanced, standard, basic, minimal - error todo - } - proc define {args} { - variable rawdef_cache - variable id_cache_rawdef - variable argdata_cache - if {[dict exists $rawdef_cache $args]} { - return [dict get [dict get $rawdef_cache $args] -id] - } else { - set id [rawdef_id $args] - if {[id_exists $id]} { - #we seem to be re-creating a previously defined id... - #clear any existing caches for this id - puts stderr "punk::args::define Redefinition of id:$id - clearing existing data" - - #dict unset argdata_cache $prevraw ;#silently does nothing if key not present - dict for {k v} $argdata_cache { - if {[dict get $v id] eq $id} { - dict unset argdata_cache $k - } - } - dict for {k v} $rawdef_cache { - if {[dict get $v -id] eq $id} { - dict unset rawdef_cache $k - } - } - dict unset id_cache_rawdef $id - } - set is_dynamic [rawdef_is_dynamic $args] - set defspace [uplevel 1 {::namespace current}] - dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic -defspace $defspace] - dict set id_cache_rawdef $id $args - return $id - } - } - - proc idquery_info {id} { - variable id_cache_rawdef - variable rawdef_cache - if {[dict exists $id_cache_rawdef $id]} { - set sep [string repeat - 40] - set rawdef [dict get $id_cache_rawdef $id] - if {[dict exists $rawdef_cache $rawdef]} { - set idinfo [dict get $rawdef_cache $rawdef] - } else { - set idinfo "" - } - set result "raw definition:" - append result \n $sep - append result \n $rawdef - append result \n $sep - append result \n "id info:" - append result \n $idinfo - append result \n $sep - variable argdata_cache - #lsearch -stride not avail (or buggy) in some 8.6 interps - search manually for now (2025). todo - modernize some time after Tcl 9.0/9.1 more widespread.(2027?) - #check for and report if id is present multiple times - set argdata_records [list] - dict for {k v} $argdata_cache { - if {[dict get $v id] eq $id} { - if {$k eq $rawdef} { - lappend argdata_records [list 1 $k $v] - } else { - lappend argdata_records [list 0 $k $v] - } - } - } - append result \n "argdata cache:" - if {![llength $argdata_records]} { - append result \n "(not present)" - } else { - append result \n "present [llength $argdata_records] time(s)" - foreach r $argdata_records { - lassign $r match k v - if {$match} { - append result \n " - present with same rawdef key" - } else { - append result \n " - present with different rawdef key" - append result \n " [punk::lib::indent $k { }]" - } - } - if {[llength $argdata_records] > 1} { - append result \n "*more than one record was not expected - review*" - } - } - append result \n $sep - return $result - } - } - - proc define2 {args} { - dict get [resolve {*}$args] id - } - - proc resolve {args} { - variable rawdef_cache - variable id_cache_rawdef - set defspace "" - if {[dict exists $rawdef_cache $args]} { - set cinfo [dict get $rawdef_cache $args] - set id [dict get $cinfo -id] - set is_dynamic [dict get $cinfo -dynamic] - if {[dict exists $cinfo -defspace]} { - set defspace [dict get $cinfo -defspace] - } - } else { - #should we really be resolving something that hasn't been defined? - set id [rawdef_id $args] - puts stderr "Warning: punk::args::resolve called with undefined id:$id" - set is_dynamic [rawdef_is_dynamic $args] - dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] - dict set id_cache_rawdef $id $args - } - - - variable argdata_cache - variable argdefcache_unresolved - - - set cache_key $args - #ideally we would use a fast hash algorithm to produce a short key with low collision probability. - #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) - #review - check if there is a built-into-tcl way to do this quickly - #for now we will just key using the whole string - #performance seems ok - memory usage probably not ideal - #quote from DKF 2021 - #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. - #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. - #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. - #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). - #> If dealing with very large amounts of data, using a database is probably a good plan. - - set textargs $args - if {![llength $args]} { - punk::args::get_by_id ::punk::args::define {} - return - } - #if {[lindex $args 0] eq "-dynamic"} { - # set is_dynamic [lindex $args 1] - # set textargs [lrange $args 2 end] - #} - - #experimental - set LVL 2 - - if {!$is_dynamic} { - if {[tcl::dict::exists $argdata_cache $cache_key]} { - return [tcl::dict::get $argdata_cache $cache_key] - } - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - if {[string first \$\{ $optionspecs] > 0} { - if {$defspace ne ""} { - #normal/desired case - set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } else { - #todo - deprecate/stop from happening? - puts stderr "punk::args::resolve calling tstr for id:$id with no known definition space (-defspace empty)" - set optionspecs [uplevel $LVL [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } - } - } else { - - if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { - set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel $LVL [list ::subst $param]] - } - } else { - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - #dynamic - double substitution required. - #e.g - # set DYN_CHOICES {${[::somewhere::get_choice_list]}} - # set RED [punk::ansi::a+ bold red] - # set RST [punk::ansi::a] - # punk::args::define { - # -arg -choices {${$DYN_CHOICES}} -help "${$RED}important info${$RST}" - #} - if {$defspace ne ""} { - set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } - #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) - if {[string first \$\{ $optionspecs] > 0} { - set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel $LVL [list ::subst $param]] - } - tcl::dict::set argdefcache_unresolved $cache_key $pt_params - } - } - #argdata_cache should be limited in some fashion or will be a big memory leak??? - if {[tcl::dict::exists $argdata_cache [list $optionspecs]]} { - #resolved cache version exists - return [tcl::dict::get $argdata_cache [list $optionspecs]] - } - } - - - - #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices - #default to 1 for convenience - - #checks with no default - #-minsize -maxsize -range - - - #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi - #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist - - #set opt_defaults [tcl::dict::create] - #set val_defaults [tcl::dict::create] - - #set opt_solos [list] - #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end - - set records [list] - set linebuild "" - - set linelist [split $optionspecs \n] - set lastindent "" - foreach ln $linelist { - if {[tcl::string::trim $ln] eq ""} {continue} - regexp {(\s*).*} $ln _all lastindent - break ;#break at first non-empty - } - #puts "indent1:[ansistring VIEW $lastindent]" - set in_record 0 - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - foreach rawline $linelist { - set recordsofar [tcl::string::cat $linebuild $rawline] - #ansi colours can stop info complete from working (contain square brackets) - #review - when exactly are ansi codes allowed/expected in record lines. - # - we might reasonably expect them in default values or choices or help strings - # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. - # - eg set line "set x \"a[a+ red]red[a]\"" - # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket - if {$has_punkansi} { - set test_complete [punk::ansi::ansistrip $recordsofar] - } else { - #review - #we only need to strip enough to stop interference with 'info complete' - set test_complete [string map [list \x1b\[ ""] $recordsofar] - } - if {![tcl::info::complete $test_complete]} { - #append linebuild [string trimleft $rawline] \n - if {$in_record} { - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. - #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. - #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. - #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) - #(note string first "" $str is fast and returns -1) - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline \n - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline \n - } else { - append linebuild $rawline \n - } - } else { - set in_record 1 - regexp {(\s*).*} $rawline _all lastindent - #puts "indent: [ansistring VIEW -lf 1 $lastindent]" - #puts "indent from rawline:$rawline " - append linebuild $rawline \n - } - } else { - set in_record 0 - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline - } else { - append linebuild $rawline - } - lappend records $linebuild - set linebuild "" - } - } - set cmd_info {} - set package_info {} - set id_info {} ;#e.g -children ?? - set doc_info {} - #set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table - set seealso_info {} - set keywords_info {} - ###set leader_min 0 - ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit - #set leader_max "" - #(common case of no leaders specified) - #set opt_any 0 - #set val_min 0 - #set val_max -1 ;#-1 for no limit - set DEF_definition_id $id - - #form_defs - set F [dict create _default [New_command_form _default]] - set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under - - #set ARGSPACE [dict create] ;#keyed on form - #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values - - set refs [dict create] - set record_type "" - set record_number -1 ;# - foreach rec $records { - set trimrec [tcl::string::trim $rec] - switch -- [tcl::string::index $trimrec 0] { - "" - # {continue} - } - incr record_number - set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict - if {[llength $record_values] % 2 != 0} { - #todo - avoid raising an error - store invalid defs keyed on id - error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" - } - # ---------------------------------------------------------- - # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. - #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! - #(form_ids_active is otherwise set in the @form handling block) - - #consider the following 2 line entry which is potentially dynamically included via a tstr: - # @form -form {* newform} - # @form -form {newform} -synopsis "cmd help ?stuff?" - #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. - #(because _default is usually 'taken over' by the first encountered form id) - #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record - #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. - - if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { - set patterns [dict get $record_values -form] - set record_form_ids [list] - foreach p $patterns { - if {[regexp {[*?\[\]]} $p]} { - #isglob - only used for matching existing forms - lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] - } else { - #don't test for existence - will define new form if necessary - lappend record_form_ids $p - } - } - #-form values could be globs that didn't match. record_form_ids could be empty.. - if {[llength $record_form_ids]} { - #only rename _default if it's the sole entry - if {[dict size $F] == 1 && [dict exists $F "_default"]} { - if {"_default" ni $record_form_ids} { - #only initial form exists - but we are mentioning new ones - #first rename the _default to first encountered new form id - #(just replace whole dict with new key - same data) - set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] - #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F - #we are only setting active because of the rename - @form is the way to change active forms list - set form_ids_active [lindex $record_form_ids 0] - } - } - foreach fid $record_form_ids { - if {![dict exists $F $fid]} { - if {$firstword eq "@form"} { - #only @form directly supplies keys - dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] - } else { - dict set F $fid [New_command_form $fid] - } - } else { - #update form with current record opts, except -form - if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } - } - } - } - } else { - #missing or empty -form - set record_form_ids $form_ids_active - if {$firstword eq "@form"} { - foreach fid $form_ids_active { - dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] - } - } - } - # ---------------------------------------------------------- - - set firstchar [tcl::string::index $firstword 0] - set secondchar [tcl::string::index $firstword 1] - if {$firstchar eq "@" && $secondchar ne "@"} { - set record_type "directive" - set directive_name $firstword - set at_specs $record_values - - switch -- [tcl::string::range $directive_name 1 end] { - dynamic { - set is_dynamic 1 - } - id { - #disallow duplicate @id line ? - #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) - - #id An id will be allocated if no id line present or the -id value is "auto" - - if {[dict exists $at_specs -id]} { - set thisid [dict get $at_specs -id] - if {$thisid ni [list $id auto]} { - error "punk::args::define @id mismatch existing: $id vs $thisid" - } - } - set id_info $at_specs - } - ref { - #a reference within the definition - #e.g see punk::args::tclcore ::after - #global reference dict - independent of forms - #ignore refs without an -id - #store all keys except -id - #complete overwrite if refid repeated later on - if {[dict exists $at_specs -id]} { - dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] - } - } - default { - #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple - #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) - #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) - #That is possibly too complicated and/or unnecessary? - #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? - - if {[dict exists $at_specs -id]} { - set copyfrom [get_spec [dict get $at_specs -id]] - #we don't copy the @id info from the source - #for now we only copy across if nothing set.. - #todo - bring across defaults for empty keys at targets? - #need to keep it simple enough to reason about behaviour easily.. - if {[dict size $copyfrom]} { - if {![dict size $cmd_info]} { - set cmd_info [dict get $copyfrom cmd_info] - } - if {![dict size $doc_info]} { - set doc_info [dict get $copyfrom doc_info] - } - - #foreach fid $record_form_ids { - # #only use elements with matching form id? - # #probably this feature mainly useful for _default anyway so that should be ok - # #cooperative doc sets specified in same file could share via known form ids too - # FORMDISPLAY has keys -header -body - # if {![dict size $F $fid $FORMDISPLAY]} { - # if {[dict exists $copyfrom FORMS $fid FORMDISPLAY]} { - # dict set F $fid FORMDISPLAY [dict get $copyfrom FORMS $fid FORMDISPLAY] - # } - # } - # #TODO - # #create leaders opts vals depending on position of @default line? - # #options on @default line to exclude/include sets??? - #} - } - } - } - form { - # arity system ? - #handle multiple parsing styles based on arities and keyword positions (and/or flags?) - #e.g see lseq manual with 3 different parsing styles. - #aim to produce a table/subtable for each - # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ - # -arities { - # 2 - # {3 anykeys {1 .. 1 to}} - # {4 anykeys {3 by}} - # {5 anykeys {1 .. 1 to 3 by}} - # }\ - # -fallback 1 - # ... - # @parser -synopsis "start 'count' count ??'by'? step?"\ - # -arities { - # {3 anykeys {1 count}} - # } - # ... - # @form -synopsis "count ?'by' step?"\ - # -arities { - # 1 - # {3 anykeys {1 by}} - # } - # - # see also after manual - # @form -arities {1} - # @form -arities { - # 1 anykeys {0 info} - # } - #todo - - #can we generate a form synopsis if -synopsis not supplied? - - #form id can be list of ints|names?, or * - if {[dict exists $at_specs -form]} { - set idlist [dict get $at_specs -form] - if {$idlist eq "*"} { - #* only applies to form ids that exist at the time - set idlist [dict keys $F] - } - set form_ids_active $idlist - } - #new form keys already created if they were needed (done for all records that have -form ) - } - package { - set package_info [dict merge $package_info $at_specs] - } - cmd { - #allow arbitrary - review - set cmd_info [dict merge $cmd_info $at_specs] - } - doc { - set doc_info [dict merge $doc_info $at_specs] - } - formdisplay { - #override the displayed argument table for the form. - #(formdisplay keys -header -body) - #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing - foreach fid $record_form_ids { - tcl::dict::set F $fid FORMDISPLAY [dict merge [tcl::dict::get $F $fid FORMDISPLAY] $at_specs] - } - } - opts { - foreach fid $record_form_ids { - if {[tcl::dict::get $F $fid argspace] eq "values"} { - error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" - } - tcl::dict::set F $fid argspace "options" - set tmp_optspec_defaults [dict get $F $fid OPTSPEC_DEFAULTS] - - foreach {k v} $at_specs { - switch -- $k { - -form { - #review - handled above - } - -any - - -anyopts { - #set opt_any $v - tcl::dict::set F $fid OPT_ANY $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -choicerestricted { - #review - only apply to certain types? - tcl::dict::set tmp_optspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_optspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - index { - set v indexexpression - } - none - "" - - - any - ansistring - globstring - list { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_optspec_defaults -type $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple - - -prefix { - #allow overriding of defaults for options that occur later - tcl::dict::set tmp_optspec_defaults $k $v - } - default { - set known { -any -form -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" - } - } - } - tcl::dict::set F $fid OPTSPEC_DEFAULTS $tmp_optspec_defaults - } ;# end foreach record_form_ids - } - leaders { - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] in [list options values]} { - error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" - } - set tmp_leaderspec_defaults [dict get $F $fid LEADERSPEC_DEFAULTS] - - foreach {k v} $at_specs { - switch -- $k { - -form { - #review - handled above - } - -min - - -minvalues { - if {$v < 0} { - error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MIN $v - #if {$leader_max == 0} { - # set leader_max -1 - #} - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MAX $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -choiceinfo { - if {[llength $v] %2 != 0} { - error "punk::args::define - key '-choiceinfo' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - #-choicegroups? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_leaderspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - index { - set v indexexpression - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -ensembleparameter { - #review - tcl::dict::set tmp_leaderspec_defaults $k $v - #error "punk::args::define - -ensembleparameter not supported as a default for @leaders - only valid on actual leader arguments" - } - default { - set known { -min -form -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid LEADERSPEC_DEFAULTS $tmp_leaderspec_defaults - - } ;#end foreach record_form_ids - - } - values { - foreach fid $record_form_ids { - dict set F $fid argspace "values" - - set tmp_valspec_defaults [dict get $F $fid VALSPEC_DEFAULTS] - - foreach {k v} $at_specs { - switch -- $k { - -form { - #review - handled above - } - -min - - -minvalues { - if {$v < 0} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" - } - #set val_min $v - dict set F $fid VAL_MIN $v - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" - } - #set val_max $v - dict set F $fid VAL_MAX $v - } - -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_valspec_defaults $k $v - } - -choiceinfo - -choicegroups { - if {[llength $v] % 2 != 0} { - error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - # -choicegroups ?? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_valspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - index { - set v indexexpression - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set tmp_valspec_defaults $k $v - } - default { - set known { -min -form -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid VALSPEC_DEFAULTS $tmp_valspec_defaults - } - - } - seealso { - #todo! - #like @doc, except displays in footer, multiple - sub-table? - set seealso_info [dict merge $seealso_info $at_specs] - } - keywords { - #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? - set keywords_info [dict merge $keywords_info $at_specs] - } - default { - error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @formdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" - } - } - #record_type directive - continue - } elseif {$firstchar eq "-"} { - set argname $firstword - set argdef_values $record_values - tcl::dict::set argdef_values -ARGTYPE option - - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - dict set F $fid argspace "options" - } elseif {[dict get $F $fid argspace] eq "values"} { - error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" - } - set record_type option - dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] - #lappend opt_names $argname - } - - set is_opt 1 - } else { - set argname $firstword - if {$firstchar eq "@"} { - #allow basic @@ escaping for literal argname that begins with @ - set argname [tcl::string::range $argname 1 end] - } - - set argdef_values $record_values - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - set record_type leader - tcl::dict::set argdef_values -ARGTYPE leader - #lappend leader_names $argname - set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] - if {$argname ni $temp_leadernames} { - lappend temp_leadernames $argname - tcl::dict::set F $fid LEADER_NAMES $temp_leadernames - } else { - #This can happen if the definition has repeated values - error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" - } - - if {[dict get $F $fid LEADER_MAX] >= 0} { - if {[dict get $F $fid LEADER_MAX] < [llength $temp_leadernames]} { - puts stderr "punk::args::resolve warning arg $argname LEADER_MAX == [dict get $F $fid LEADER_MAX] but [llength $temp_leadernames] leader names found @id:$DEF_definition_id" - dict set F $fid LEADER_MAX [llength $temp_leadernames] - } - } - } else { - set record_type value - tcl::dict::set argdef_values -ARGTYPE value - set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] - if {$argname ni $temp_valnames} { - lappend temp_valnames $argname - tcl::dict::set F $fid VAL_NAMES $temp_valnames - } else { - error "punk::args::define - arg $argname already present as value in '$rec' (command form:'$fid') @id:$DEF_definition_id" - } - #lappend val_names $argname - if {[dict get $F $fid VAL_MAX] >= 0} { - if {[dict get $F $fid VAL_MAX] < [llength $temp_valnames]} { - puts stderr "punk::args::resolve warning arg $argname VAL_MAX == [dict get $F $fid VAL_MAX] but [llength $temp_valnames] value names found @id:$DEF_definition_id" - dict set F $fid VAL_MAX [llength $temp_valnames] - } - } - } - } - - set is_opt 0 - } - - - #assert - we only get here if it is a value or flag specification line. - #assert argdef_values has been set to the value of record_values - - foreach fid $record_form_ids { - if {$is_opt} { - set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS] - } else { - if {[dict get $F $fid argspace] eq "values"} { - set spec_merged [dict get $F $fid VALSPEC_DEFAULTS] - } else { - set spec_merged [dict get $F $fid LEADERSPEC_DEFAULTS] - } - } - - # -> argopt argval - foreach {spec specval} $argdef_values { - #literal-key switch - bytecompiled to jumpTable - switch -- $spec { - -form { - - } - -type { - #normalize here so we don't have to test during actual args parsing in main function - switch -- [tcl::string::tolower $specval] { - int - integer { - tcl::dict::set spec_merged -type int - } - bool - boolean { - tcl::dict::set spec_merged -type bool - } - char - character { - tcl::dict::set spec_merged -type char - } - dict - dictionary { - tcl::dict::set spec_merged -type dict - } - index - indexexpression { - tcl::dict::set spec_merged -type indexexpression - } - "" - none { - if {$is_opt} { - tcl::dict::set spec_merged -type none - 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. - } - } else { - #-solo only valid for flags - error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" - } - } - any - anything { - tcl::dict::set spec_merged -type any - } - ansi - ansistring { - tcl::dict::set spec_merged -type ansistring - } - any - string - globstring { - tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - } - literal { - #value is the name of the argument - if {$is_opt} { - error "punk::args::define - invalid -type 'literal' for flag argument '$argname' @id:$DEF_definition_id" - } - tcl::dict::set spec_merged -type literal - } - default { - #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW - tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - } - } - } - -default - -solo - -range - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo - - -minsize - -maxsize - -nocase - -optional - -multiple - - -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - - -regexprepass - -regexprefail - -regexprefailmsg - { - #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines - #review -solo 1 vs -type none ? conflicting values? - tcl::dict::set spec_merged $spec $specval - } - -ensembleparameter { - #review - only leaders? - tcl::dict::set spec_merged $spec $specval - } - -prefix { - #for flags/options - tcl::dict::set spec_merged $spec $specval - } - -validationtransform { - #string is dict only 8.7/9+ - if {[llength $specval] % 2} { - error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" - } - dict for {tk tv} $specval { - switch -- $tk { - -function - -type - -minsize - -maxsize - -range { - } - default { - set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? - error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" - } - } - } - - } - default { - if {[string match ref-* $spec]} { - #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) - #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. - if {![tcl::dict::exists $refs $specval]} { - puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" - } else { - set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" - if {$targetswitch eq "-*"} { - set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id - } else { - if {[tcl::dict::exists $refs $specval $targetswitch]} { - tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] - } else { - puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" - } - } - } - } else { - set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - -ensembleparameter\ - ] - error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" - } - } - } - } ;# end foreach {spec specval} argdef_values - - - if {$is_opt} { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - if {[tcl::dict::get $spec_merged -type] eq "none"} { - #JJJJ - dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname] - } - } else { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - tcl::dict::set F $fid ARG_INFO $argname $spec_merged - #review existence of -default overriding -optional - if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} { - if {$is_opt} { - set temp_opt_required [dict get $F $fid OPT_REQUIRED] - lappend temp_opt_required $argname - dict set F $fid OPT_REQUIRED $temp_opt_required - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - set temp_leader_required [dict get $F $fid LEADER_REQUIRED] - lappend temp_leader_required $argname - dict set F $fid LEADER_REQUIRED $temp_leader_required - } else { - set temp_val_required [dict get $F $fid VAL_REQUIRED] - lappend temp_val_required $argname - dict set F $fid VAL_REQUIRED $temp_val_required - } - } - } - if {[tcl::dict::exists $spec_merged -default]} { - if {$is_opt} { - #tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] - tcl::dict::set F $fid OPT_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } else { - #tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] - tcl::dict::set F $fid VAL_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } - } - } - } ;# end foreach fid record_form_ids - - } ;# end foreach rec $records - - - #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { - # variable id_counter - # set DEF_definition_id "autoid_[incr id_counter]" - #} - - - #now cycle through ALL forms not just form_ids_active (record_form_ids) - dict for {fid formdata} $F { - # REVIEW - #no values specified - we can allow last leader to be multiple - foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { - error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" - } - } - - #todo - disallow any -multiple == true entries if any leaders have -multiple == true? - #(creates parsing ambiguity) - #ambiguity could be resolved if at least one required option/flag eg -- - #ambiguities could theoretically also be resolved with required literals or choices - or even based on argument type - #(overcomplex? todo see if any core/tcllib commands work like that) - - #only allow a single entry within VAL_NAMES to have -multiple == true - #example of command with non-trailing -multiple == true is core command: 'file copy ?-force? ?--? source ?source?... targetDir - set val_multiples 0 - foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { - if {$val_multiples > 0} { - error "bad setting -multiple true on argument spec for value '$valname' in command form:'$fid'. Only a single value argument specification can be marked with -multiple true @id:$DEF_definition_id" - } - incr val_multiples - } - } - - #todo - document that ambiguities in API are likely if both @leaders and @values used - #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) - - - dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata LEADERSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata OPTSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata VALSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - - - - - #todo - precalculate a set of 'arity' entries for each form - #We want a structure for the arg parser to get easy access and make a fast decision on which form applies - #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? - #1) after ms (1 1) - #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? - #3) after cancel id (2 2) - #4) after cancel script ?script...? (2 -1) - #5) after idle script ?script...? (1 -1) - #6) after info ?id? (1 2) - - #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) - - #in the above case we have no unique total_arity - #we would also want to consider values when selecting - #e.g given the invalid command "after cancel" - # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. - - - - set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands - #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use - #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form - #e.g commandline completion could show list of synopsis entries to select from - - set form_info [dict create] - dict for {fid fdict} $F { - dict set form_info $fid {} - dict for {optk optv} $fdict { - if {[string match -* $optk]} { - dict set form_info $fid $optk $optv - } - } - } - - set argdata_dict [tcl::dict::create\ - id $DEF_definition_id\ - cmd_info $cmd_info\ - doc_info $doc_info\ - package_info $package_info\ - seealso_info $seealso_info\ - id_info $id_info\ - FORMS $F\ - form_names [dict keys $F]\ - form_info $form_info\ - ] - - tcl::dict::set argdata_cache $cache_key $argdata_dict - if {$is_dynamic} { - #also cache resolved version - tcl::dict::set argdata_cache [list $optionspecs] $argdata_dict - } - - #tcl::dict::set id_cache_rawdef $DEF_definition_id $args - #puts "xxx:$result" - return $argdata_dict - } - - #return raw definition list as created with 'define' - # - possibly with unresolved dynamic parts - proc raw_def {id} { - variable id_cache_rawdef - set realid [real_id $id] - if {![dict exists $id_cache_rawdef $realid]} { - return "" - } - return [tcl::dict::get $id_cache_rawdef $realid] - } - - - namespace eval argdoc { - variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @formdisplay @seealso @leaders @opts @values leaders opts values} - variable resolved_def_TYPE_CHOICEGROUPS { - directives {@id @package @cmd @ref @doc @formdisplay @seealso} - argumenttypes {leaders opts values} - remaining_defaults {@leaders @opts @values} - } - - lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { - @id -id ::punk::args::resolved_def - @cmd -name punk::args::resolved_def -help\ - "Resolves or retrieves the previously resolved definition and - uses the 'spec' form to build a response in definition format. - - Pulling argument definition data from another function is a form - of tight coupling to the other function that should be done with - care. - - Note that the directives @leaders @opts @values may appear multiple - times in a source definition - applying defaults for arguments that - follow. When retrieving these - there is only a single result for - each that represents the defaults after all have been applied. - When retrieving -types * each of these will be positioned before - the arguments of that type - but this doesn't mean there was a single - leading directive for this argument type in the source definition. - Each argument has already had its complete specification recorded in - its own result. - - When manually specifying -types, the order @leaders then @opts then - @values must be maintained - but if they are placed before their - corresponding arguments, they will not affect the retrieved arguments - as these arguments are already fully spec'd. The defaults from the - source can be removed by adding @leaders, @opts @values to the - -antiglobs list, but again - this won't affect the existing arguments. - Each argument can have members of its spec overridden using the - -override dictionary. - " - @leaders -min 0 -max 0 - @opts - -return -default text -choices {text dict} - -form -default 0 -help\ - "Ordinal index or name of command form" - - #no restriction on number of types/repetitions? - -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} - -antiglobs -default {} -type list -help\ - "Glob patterns for directive or argument/flags to - be suppressed" - -override -type dict -optional 1 -default "" -help\ - "dict of dicts. Key in outer dict is the name of a - directive or an argument. Inner dict is a map of - overrides/additions (- ...) for that line. - " - @values -min 1 -max -1 - id -type string -help\ - "identifer for a punk::args definition - This will usually be a fully-qualifed - path for a command name" - pattern -type string -optional 1 -default * -multiple 1 -help\ - "glob-style patterns for retrieving value or switch - definitions. - - If -type is * and pattern is * the entire definition including - directive lines will be returned in line form. - (directives are lines beginning with - @ e.g @id, @cmd etc) - - if -type is leaders,opts or values matches from that type - will be returned. - - if -type is another directive such as @id, @doc etc the - patterns are ignored. - - " - }]] - } - - - proc resolved_def {args} { - #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. - set opts [dict create\ - -return text\ - -types {}\ - -form 0\ - -antiglobs {}\ - -override {}\ - ] - if {[llength $args] < 1} { - #must have at least id - punk::args::parse $args withid ::punk::args::resolved_def - return - } - set patterns [list] - - #a definition id must not begin with "-" ??? review - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {$a in {-type -types}} { - incr i - dict set opts -types [lindex $args $i] - } elseif {[string match -* $a]} { - incr i - dict set opts $a [lindex $args $i] - } else { - set id [lindex $args $i] - set patterns [lrange $args $i+1 end] - break - } - if {$i == [llength $args]-1} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - if {![llength $patterns]} { - set patterns [list *] - } - dict for {k v} $opts { - switch -- $k { - -return - -form - -types - -antiglobs - -override {} - default { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - } - set typelist [dict get $opts -types] - if {[llength $typelist] == 0} { - set typelist {*} - } - foreach type $typelist { - if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - - - variable id_cache_rawdef - set realid [real_id $id] - if {$realid eq ""} { - return - } - - set deflist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] - - set opt_form [dict get $opts -form] - if {[string is integer -strict $opt_form]} { - set formname [lindex [dict get $specdict form_names] $opt_form] - } else { - set formname $opt_form - } - set opt_override [dict get $opts -override] - set opt_return [dict get $opts -return] - - #set arg_info [dict get $specdict ARG_INFO] - set arg_info [dict get $specdict FORMS $formname ARG_INFO] - set argtypes [dict create leaders leader opts option values value] - - set opt_antiglobs [dict get $opts -antiglobs] - set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] - set suppressed_directives [list] - set suppressed_args [list] - foreach ag $opt_antiglobs { - foreach d $directives { - if {[string match $ag $d]} { - lappend suppressed_directives $d - } - } - foreach argname [dict keys $arg_info] { - if {[string match $ag $argname]} { - lappend suppressed_args $argname - } - } - } - set suppressed_directives [lsort -unique $suppressed_directives] - set suppressed_args [lsort -unique $suppressed_args] - - set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] - - set globbed [list] - foreach pat $patterns { - set matches [dict keys $arg_info $pat] - lappend globbed {*}$matches - } - set globbed [lsort -unique $globbed] - #maintain order of original arg_info keys in globbed results - set ordered_globbed [list] - foreach a [dict keys $arg_info] { - if {$a ni $ordered_globbed && $a in $globbed} { - lappend ordered_globbed $a - } - } - set included_args [punk::args::system::punklib_ldiff $ordered_globbed $suppressed_args] - - set result "" - set resultdict [dict create] - foreach type $typelist { - switch -exact -- $type { - * { - if {"@id" in $included_directives} { - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - foreach directive {@package @cmd @doc @seealso} { - set dshort [string range $directive 1 end] - if {"$directive" in $included_directives} { - if {[dict exists $opt_override $directive]} { - append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict ${dshort}_info]" - dict set resultdict $directive [dict get $specdict ${dshort}_info] - } - } - } - - #todo @formdisplay - - - #output ordered by leader, option, value - foreach pseudodirective {leaders opts values} tp {leader option value} { - set directive "@$pseudodirective" - switch -- $directive { - @leaders {set defaults_key LEADERSPEC_DEFAULTS} - @opts {set defaults_key OPTSPEC_DEFAULTS} - @values {set defaults_key VALSPEC_DEFAULTS} - } - - if {"$directive" in $included_directives} { - if {[dict exists $opt_override "$directive"]} { - append result \n "$directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict FORMS $formname $defaults_key]" - dict set resultdict $directive [dict get $specdict FORMS $formname $defaults_key] - } - } - - if {$pseudodirective in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq $tp} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "$m $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - - } - @id { - if {"@id" in $included_directives} { - #only a single id record can exist - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - } - @package - @cmd - @doc - @seealso { - if {"$type" in $included_directives} { - set tp [string range $type 1 end] ;# @package -> package - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict ${tp}_info]" - dict set resultdict $type [dict get $specdict ${tp}_info] - } - } - #todo @formdisplay - } - @leaders - @opts - @values { - #these are the active defaults for further arguments - if {"$type" in $included_directives} { - switch -- $type { - @leaders {set defaults_key LEADERSPEC_DEFAULTS} - @opts {set defaults_key OPTSPEC_DEFAULTS} - @values {set defaults_key VALSPEC_DEFAULTS} - } - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS]" - dict set resultdict $type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] - } - } - } - leaders - opts - values { - #pseudo-directives - if {$type in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "$m [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "$m $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - default { - } - } - if {$opt_return eq "text"} { - return $result - } else { - return $resultdict - } - } - } - - proc resolved_def_values {id {patternlist *}} { - variable id_cache_rawdef - set realid [real_id $id] - if {$realid ne ""} { - set deflist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [resolve {*}$deflist] - set arg_info [dict get $specdict ARG_INFO] - set valnames [dict get $specdict VAL_NAMES] - set result "" - if {$patternlist eq "*"} { - foreach v $valnames { - set def [dict get $arg_info $v] - set def [dict remove $def -ARGTYPE] - append result \n "$v $def" - } - return $result - } else { - foreach pat $patternlist { - set matches [dict keys $arg_info $pat] - set matches [lsearch -all -inline -glob $valnames $pat] - foreach m $matches { - set def [dict get $arg_info $m] - set def [dict remove $def -ARGTYPE] - append result \n "$m $def" - } - } - return $result - } - } - } - #proc resolved_def_leaders ?? - #proc resolved_def_opts ?? - - proc get_spec {id} { - set deflist [raw_def $id] - if {$deflist eq ""} { - return - } - return [resolve {*}$deflist] - #if {[id_exists $id]} { - # return [resolve {*}[raw_def $id]] - #} - } - proc is_dynamic {id} { - variable id_cache_rawdef - variable rawdef_cache - set deflist [raw_def $id] - if {[dict exists $rawdef_cache $deflist -dynamic]} { - return [dict get $rawdef_cache $deflist -dynamic] - } - return [rawdef_is_dynamic $deflist] - #@dynamic only has meaning as 1st element of a def in the deflist - } - - #@id must be within first 4 lines of a block - or assign auto - #review - @dynamic block where -id not explicitly set? - disallow? - proc rawdef_id {rawdef} { - set id "" - foreach d $rawdef { - foreach ln [lrange [split $d \n] 0 4] { - if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { - if {$firstword eq "@id"} { - if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { - set id [dict get $rest -id] - break - } - } - } - } - if {$id ne ""} { - break - } - } - if {$id eq "" || [string tolower $id] eq "auto"} { - variable id_counter - set id "autoid_[incr id_counter]" - } - #puts "==>id: $id" - return $id - } - #test the rawdef for @dynamic directive - proc rawdef_is_dynamic {rawdef} { - #temporary - old way - set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] - if {$flagged_dynamic} { - return true - } - foreach d $rawdef { - if {[regexp {\s*(\S+)} $d _match firstword]} { - if {$firstword eq "@dynamic"} { - return true - } - } - } - return false - } - - variable aliases - set aliases [dict create] - - lappend PUNKARGS [list { - @id -id ::punk::args::get_ids - @cmd -name punk::args::get_ids -help\ - "return list of ids for argument definitions" - @values -min 0 -max 1 - match -default * -help\ - "exact id or glob pattern for ids" - }] - proc get_ids {{match *}} { - variable id_cache_rawdef - variable aliases - return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] - } - - #we don't automatically test for (autodef)$id - only direct ids and aliases - proc id_exists {id} { - variable aliases - if {[tcl::dict::exists $aliases $id]} { - return 1 - } - variable id_cache_rawdef - tcl::dict::exists $id_cache_rawdef $id - } - proc set_alias {alias id} { - variable aliases - dict set aliases $alias $id - } - proc unset_alias {alias} { - variable aliases - dict unset aliases $alias - } - proc get_alias {alias} { - variable aliases - if {[dict exists $aliases $alias]} { - return [tcl::dict::get $aliases $alias] - } - } - - proc real_id {id} { - variable id_cache_rawdef - variable aliases - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } else { - set check_updates [list [namespace qualifiers $id]] - #puts stderr "---->real_id '$id' update_definitions $check_updates" - if {![llength [update_definitions $check_updates]]} { - #nothing new loaded - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } else { - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } - } - } - - proc status {} { - upvar ::punk::args::register::NAMESPACES registered - upvar ::punk::args::register::loaded_packages loaded_packages - upvar ::punk::args::register::loaded_info loaded_info - upvar ::punk::args::register::scanned_packages scanned_packages - upvar ::punk::args::register::scanned_info scanned_info - set result "" - # [format %-${w0}s $idtail] - set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] - append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n - set width_c2 [string length "Scanned_ids"] - set width_c3 [string length "Scantime_us"] - set width_c4 [string length "Loaded_defs"] - set width_c5 [string length "Loadtime_us"] - set count_unloaded 0 - set count_loaded 0 - foreach ns $registered { - if {$ns in $scanned_packages} { - set ids [dict get $scanned_info $ns idcount] - set scan_us [dict get $scanned_info $ns time] - } else { - set ids "" - set scan_us "" - } - if {$ns in $loaded_packages} { - incr count_loaded - set ldefs [dict get $loaded_info $ns defcount] - set load_us [dict get $loaded_info $ns time] - } else { - incr count_unloaded - set ldefs "" - set load_us "" - } - append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n - } - append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" - return $result - } - - #scanned_packages (list) - #namespace_docpackages (dict) - proc update_definitions {{nslist *}} { - #puts "----> update_definitions '$nslist'" - if {[set gposn [lsearch $nslist {}]] >= 0} { - lset nslist $gposn :: - } - upvar ::punk::args::register::NAMESPACES registered ;#list - upvar ::punk::args::register::loaded_packages loaded_packages ;#list - upvar ::punk::args::register::loaded_info loaded_info ;#dict - upvar ::punk::args::register::scanned_packages scanned_packages ;#list - upvar ::punk::args::register::scanned_info scanned_info ;#dict - upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict - - - #puts stderr "-->update_definitions '$nslist'" - #needs to run quickly - especially when no package namespaces to be scanned for argdefs - #e.g - gets called for each subcommand of an ensemble (could be many) - # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. - #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. - # -- --- --- --- --- --- - # common-case fast-path - - if {[llength $loaded_packages] == [llength $registered]} { - #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. - #assert - if all are registered - then all have been scanned - return {} - } - # -- --- --- --- --- --- - - set unscanned [punklib_ldiff $registered $scanned_packages] - if {[llength $unscanned]} { - foreach pkgns $unscanned { - set idcount 0 - set ts_start [clock microseconds] - if {[info exists ${pkgns}::PUNKARGS]} { - set seen_documentedns [list] ;#seen per pkgns - foreach definitionlist [set ${pkgns}::PUNKARGS] { - #namespace eval $evalns [list punk::args::define {*}$definitionlist] - set id [rawdef_id $definitionlist] - if {[string match autoid_* $id]} { - puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" - puts stderr "definition:\n" - foreach d $definitionlist { - set out "" - foreach ln [split $d \n] { - append out " " $ln \n - } - puts $out - } - continue - } - #todo - detect duplicate ids (last will silently win.. should be reported somewhere) - incr idcount - set documentedns [namespace qualifiers $id] - if {$documentedns eq ""} {set documentedns ::} - if {$documentedns ni $seen_documentedns} { - #don't add own ns as a key in namespace_docpackages - if {$documentedns ne $pkgns} { - dict lappend namespace_docpackages $documentedns $pkgns - } - lappend seen_documentedns $documentedns - } - } - } - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - dict set scanned_info $pkgns [dict create time $diff idcount $idcount] - #we count it as scanned even if PUNKARGS didn't exist - #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) - lappend scanned_packages $pkgns - } - } - - - - if {"*" in $nslist} { - set needed [punklib_ldiff $registered $loaded_packages] - } else { - set needed [list] - foreach pkgns $nslist { - if {![string match ::* $pkgns]} { - puts stderr "warning: update_definitions received unqualified ns: $pkgns" - set pkgns ::$pkgns - } - if {$pkgns in $registered && $pkgns ni $loaded_packages} { - lappend needed $pkgns - } - #argdoc sub namespace is a standard place to put defs that match the namespace below - #(generally the PUNKARGS in a namespace should apply to own ns) - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { - lappend needed $docns - } - } - if {[dict exists $namespace_docpackages $pkgns]} { - #this namespace has other argdef sources - foreach docns [dict get $namespace_docpackages $pkgns] { - if {$docns ni $loaded_packages} { - lappend needed $docns - } - } - } - } - } - - - - set newloaded [list] - foreach pkgns $needed { - #puts stderr "update_definitions Loading: $pkgns" - set ts_start [clock microseconds] - set def_count 0 - if {![catch { - if {[info exists ${pkgns}::PUNKARGS]} { - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - namespace eval ${pkgns}::argdoc { - set epath [namespace path] - set pkgns [namespace parent] - if {$pkgns ni $epath} { - namespace path [list {*}$epath $pkgns] ;#add to tail - } - - } - set evalns $docns - } else { - set evalns $pkgns - } - foreach definitionlist [set ${pkgns}::PUNKARGS] { - namespace eval $evalns [list punk::args::define {*}$definitionlist] - incr def_count - } - } - - #process list of 2-element lists - if {[info exists ${pkgns}::PUNKARGS_aliases]} { - foreach adef [set ${pkgns}::PUNKARGS_aliases] { - punk::args::set_alias {*}$adef - } - } - } errMsg]} { - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - lappend loaded_packages $pkgns - lappend newloaded $pkgns - dict set loaded_info $pkgns [dict create time $diff defcount $def_count] - } else { - puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" - } - } - return $newloaded - } - - #for use within get_dict only - #This mechanism gets less-than-useful results for oo methods - #e.g {$obj} - proc Get_caller {} { - #set call_level -3 ;#for get_dict call - set call_level -4 - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - #puts "-->$cmdinfo" - #puts "-->[tcl::info::frame -3]" - while {[string last \n $cmdinfo] >= 1} { - #looks like a script - haven't gone up far enough? - #(e.g patternpunk oo system: >punk . poses -invalidoption) - incr call_level -1 - if {[catch { - set nextup [tcl::info::frame $call_level] - } ]} { - break - } - set cmdinfo [tcl::dict::get $nextup cmd] - set caller [regexp -inline {\S+} $cmdinfo] - if {[interp alias {} $caller] ne ""} { - #puts "found alias for caller $caller to [interp alias {} $caller]" - #see if we can go further - incr call_level -1 - if {[catch { - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - } errM ]} { - puts "err: $errM" - break - } - } - } - set caller [regexp -inline {\S+} $cmdinfo] - if {$caller eq "namespace"} { - # review - message? - set cmdinfo "Get_caller (punk::args::get_dict?) called from namespace" - } - return $cmdinfo - } - - - # -------------------------------------- - #test of Get_caller - lappend PUNKARGS [list { - @id -id ::punk::args::test1 - @values -min 0 -max 0 - }] - proc test_get_dict {args} { - punk::args::get_dict [punk::args::raw_def ::punk::args::test1] $args - } - proc test_get_by_id {args} { - punk::args::get_by_id ::punk::args::test1 $args - } - #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. - proc test_callers {args} { - if {![llength $args]} { - puts "these test functions accept no arguments" - puts "Call with arg(s) to compare error output" - } - - if {[catch {test_get_dict {*}$args} errM]} { - puts $errM - } - puts "------------" - if {[catch {test_get_by_id {*}$args} errM]} { - puts $errM - } - return done - } - # -------------------------------------- - - set map "" - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::arg_error - @cmd -name punk::args::arg_error -help\ - "Generates a table (by default) of usage information for a command. - A trie system is used to create highlighted prefixes for command - switches and for subcommands or argument/switch values that accept - a defined set of choices. These prefixes match the mechanism used - to validate arguments (based on tcl::prefix::match). - - This function is called during the argument parsing process - (if the definition is not only being used for documentation) - It is also called by punk::args::usage which is in turn - called by the punk::ns introspection facilities which creates - on the fly definitions for some commands such as ensembles and - oo objects where a manually defined one isn't present. - " - @leaders -min 2 -max 2 - msg -type string -help\ - "Error message to display immediately prior to usage table. - May be empty string to just display usage. - " - spec_dict -type dict -help\ - "Dictionary of argument specifications. - This is the internal format parsed from - the textual definition. It contains the data - organised/optimised to allow the final arg - parser/validator to make decisions. - " - @opts - -badarg -type string -help\ - "name of an argument to highlight" - -parsedargs -type dict -help\ - "Result of successful punk::pargs::parse - (currently only looks at 'received')" - -aserror -type boolean -help\ - "If true, the usage table is raised as an error message, - otherwise it is returned as a value." - -return -choices {string table tableobject} -choicelabels { - string "no table layout" - tableobject "table object cmd" - table "full table layout" - } - -scheme -default error -choices {nocolour info error} - -form -default 0 -help\ - "Ordinal index or name of command form" - }] ] - - if {[catch {package require punk::ansi}]} { - proc punk::args::a {args} {} - proc punk::args::a+ {args} {} - } else { - namespace eval ::punk::args { - namespace import ::punk::ansi::a ::punk::ansi::a+ - } - } - variable arg_error_CLR - array set arg_error_CLR {} - set arg_error_CLR(errormsg) [a+ brightred] - set arg_error_CLR(title) "" - set arg_error_CLR(check) [a+ brightgreen] - set arg_error_CLR(solo) [a+ brightcyan] - set arg_error_CLR(choiceprefix) [a+ underline] - set arg_error_CLR(badarg) [a+ brightred] - set arg_error_CLR(goodarg) [a+ green strike] - set arg_error_CLR(goodchoice) [a+ reverse] - set arg_error_CLR(linebase_header) [a+ white] - set arg_error_CLR(cmdname) [a+ brightwhite] - set arg_error_CLR(groupname) [a+ bold] - set arg_error_CLR(ansiborder) [a+ bold] - set arg_error_CLR(ansibase_header) [a+ bold] - set arg_error_CLR(ansibase_body) [a+ white] - variable arg_error_CLR_nocolour - array set arg_error_CLR_nocolour {} - set arg_error_CLR_nocolour(errormsg) [a+ bold] - set arg_error_CLR_nocolour(title) [a+ bold] - set arg_error_CLR_nocolour(check) "" - set arg_error_CLR_nocolour(solo) "" - set arg_error_CLR_nocolour(badarg) [a+ reverse] ;#? experiment - set arg_error_CLR_nocolour(goodarg) [a+ strike] - set arg_error_CLR_nocolour(cmdname) [a+ bold] - set arg_error_CLR_nocolour(linebase_header) "" - set arg_error_CLR_nocolour(linebase) "" - set arg_error_CLR_nocolour(ansibase_body) "" - variable arg_error_CLR_info - array set arg_error_CLR_info {} - set arg_error_CLR_info(errormsg) [a+ brightred bold] - set arg_error_CLR_info(title) [a+ brightyellow bold] - set arg_error_CLR_info(check) [a+ brightgreen bold] - set arg_error_CLR_info(choiceprefix) [a+ brightgreen bold] - set arg_error_CLR_info(groupname) [a+ cyan bold] - set arg_error_CLR_info(ansiborder) [a+ brightcyan bold] - set arg_error_CLR_info(ansibase_header) [a+ cyan] - set arg_error_CLR_info(ansibase_body) [a+ white] - variable arg_error_CLR_error - array set arg_error_CLR_error {} - set arg_error_CLR_error(errormsg) [a+ brightred bold] - set arg_error_CLR_error(title) [a+ brightcyan bold] - set arg_error_CLR_error(check) [a+ brightgreen bold] - set arg_error_CLR_error(choiceprefix) [a+ brightgreen bold] - set arg_error_CLR_error(groupname) [a+ cyan bold] - set arg_error_CLR_error(ansiborder) [a+ brightyellow bold] - set arg_error_CLR_error(ansibase_header) [a+ yellow] - set arg_error_CLR_error(ansibase_body) [a+ white] - - - #bas ic recursion blocker - variable arg_error_isrunning 0 - proc arg_error {msg spec_dict args} { - #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. - #accept an option here so that we can still use full output for usage requests. - #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args - #Development/experimentation may be done with full table-based error reporting - but for production release it - #may be desirable to reduce overhead on catches. - #consider per-namespace or namespace-tree configurability. - #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due - #to resource availability etc - so the slower error generation time may not always be a problem. - #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling - #code which has no use for the enhanced error info. - #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. - #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system - #todo - #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error - #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) - - #todo - document unnamed leaders and unnamed values where -min and/or -max specified - #e.g punk::args::parse {} withdef {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} - #only |?-x?|string|... is shown in the output table. - #should be something like: - # |arg | - # |?-x? | - # |arg | - # |?arg...?| - # Where/how to specify counts? - #also.. - # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? - # - - - #limit colours to standard 16 so that themes can apply to help output - variable arg_error_isrunning - if {$arg_error_isrunning} { - error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" - } - - if {[llength $args] %2 != 0} { - error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" - } - - set arg_error_isrunning 1 - - set badarg "" - set parsedargs [dict create] ;#dict with keys: leaders,opts,values,received,solos,multis (as from punk::args::parse) - set goodargs [list] - set returntype table ;#table as string - set as_error 1 ;#usual case is to raise an error - set scheme error - set form 0 - dict for {k v} $args { - set fullk [tcl::prefix::match -error "" {-badarg -parsedargs -aserror -return -scheme -form} $k] - switch -- $fullk { - -badarg { - set badarg $v - } - -parsedargs { - #todo? - dict for {set setinfo} $v { - switch -- $set { - received { - foreach {r rpos} $setinfo { - if {$r ni $goodargs} { - lappend goodargs $r - } - } - } - } - } - set parsedargs $v - } - -aserror { - if {![string is boolean -strict $v]} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" - } - set as_error $v - } - -scheme { - set scheme $v - } - -return { - if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" - } - set returntype $v - } - -form { - set form $v - } - default { - set arg_error_isrunning 0 - error "arg_error invalid option $k. Known_options: -badarg -parsedargs -aserror -scheme -return -form" - } - } - } - #todo - scheme - use config and iterm toml definitions etc - switch -- $scheme { - "" - -nocolor - -nocolour { - set scheme nocolour - } - info - error {} - default { - set scheme na - } - } - set formnames [dict get $spec_dict form_names] - if {[string is integer -strict $form]} { - if {$form < 0 || $form > [llength $formnames]-1} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" - } - set selected_forms [list [lindex $formnames $form]] - } else { - if {$form eq "*"} { - set selected_forms $formnames - } else { - if {$form in $formnames} { - set selected_forms [list $form] - } else { - set arg_error_isrunning 0 - error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" - } - } - } - - - #hack some basics for now. - #for coloured schemes - use bold as well as brightcolour in case colour off. - upvar ::punk::args::arg_error_CLR CLR - - switch -- $scheme { - nocolour { - variable arg_error_CLR_nocolour - array set CLR [array get arg_error_CLR_nocolour - } - info { - variable arg_error_CLR_info - array set CLR [array get arg_error_CLR_info] - } - error { - variable arg_error_CLR_error - array set CLR [array get arg_error_CLR_error] - } - na { - } - } - - - #set RST [a] - set RST "\x1b\[m" - set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. - - #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error - #e.g list_as_table - - # use basic colours here to support terminals without extended colours - #todo - add checks column (e.g -minsize -maxsize) - set errmsg $msg - if {![catch {package require textblock}]} { - set has_textblock 1 - } else { - set has_textblock 0 - #couldn't load textblock package - #just return the original errmsg without formatting - } - set use_table 0 - if {$has_textblock && $returntype in {table tableobject}} { - set use_table 1 - } - set errlines [list] ;#for non-textblock output - if {[catch { - if {$use_table} { - append errmsg \n - } else { - if {($returntype in {table tableobject}) && !$has_textblock} { - append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n - } else { - append errmsg \n - } - } - set cmdname [Dict_getdef $spec_dict cmd_info -name ""] - set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] - - set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] - set docurl [Dict_getdef $spec_dict doc_info -url ""] - - #set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] - #set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] - #if {"$argdisplay_header$argdisplay_body" eq ""} { - # set is_custom_argdisplay 0 - #} else { - # set is_custom_argdisplay 1 - #} - - #temp - TODO - set argdisplay_header "" - set argdisplay_body "" - set is_custom_argdisplay 0 - - - set blank_header_col [list] - if {$cmdname ne ""} { - lappend blank_header_col "" - set cmdname_display $CLR(cmdname)$cmdname$RST - } else { - set cmdname_display "" - } - if {$cmdhelp ne ""} { - lappend blank_header_col "" - #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] - set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] - } else { - set cmdhelp_display "" - } - if {$docurl ne ""} { - lappend blank_header_col "" - set docurl_display [a+ white]$docurl$RST - } else { - set docurl_display "" - } - #synopsis - set synopsis "" - set form_info [dict get $spec_dict form_info] - dict for {fid finfo} $form_info { - set form_synopsis [Dict_getdef $finfo -synopsis ""] - if {$form_synopsis eq ""} { - #todo - set form_synopsis [punk::args::synopsis -form $fid [dict get $spec_dict id]] - if {[string length $form_synopsis] > 90} { - set form_synopsis [punk::args::synopsis -return summary -form $fid [dict get $spec_dict id]] - } - if {[string match (autodef)* $form_synopsis]} { - set form_synopsis [string range $form_synopsis 9 end] - } - } - if {$fid in $selected_forms} { - set form_synopsis [punk::ansi::a+ underline]$form_synopsis[punk::ansi::a+ nounderline] - } - append synopsis $form_synopsis \n - } - if {$synopsis ne ""} { - set synopsis [string trimright $synopsis \n] - lappend blank_header_col "" - } - - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - if {$use_table} { - set t [textblock::class::table new "$CLR(title)Usage$RST"] - $t add_column -headers $blank_header_col -minwidth 3 - $t add_column -headers $blank_header_col - - if {!$is_custom_argdisplay} { - lappend blank_header_col "" - #spanned columns in default argdisplay area - $t add_column -headers $blank_header_col ;#Default - $t add_column -headers $blank_header_col ;#Multi - $t add_column -headers $blank_header_col ;#Help - set arg_colspans {1 4 0 0 0} - } else { - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - set arg_colspans {1 1} - } - } - set h 0 - if {$cmdname ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] - } else { - lappend errlines "COMMAND: $cmdname_display" - } - incr h - } - if {$cmdhelp ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] - } else { - lappend errlines "Description: $cmdhelp_display" - } - incr h - } - if {$docurl ne ""} { - if {![catch {package require punk::ansi}]} { - set docurl [punk::ansi::hyperlink $docurl] - } - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] - } else { - lappend errlines "$docname $docurl_display" - } - incr h - } - if {$synopsis ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Synopsis: [punk::ansi::ansiwrap brightwhite $synopsis]] - } else { - #todo - lappend errlines "Synopsis:\n$synopsis" - } - incr h - } - - - if {$use_table} { - if {$is_custom_argdisplay} { - if {$argdisplay_header ne ""} { - $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] - } - } else { - $t configure_header $h -values {Arg Type Default Multi Help} - } - } else { - lappend errlines " --ARGUMENTS-- " - } - - if {$is_custom_argdisplay} { - if {$use_table} { - #using overall container table - #header already added - #TODO - review textblock::table features - #we can't currently span columns within the table body. - #This feature could allow hidden data columns (and sort on hidden col?) - #potentially require coordination with header colspans? - $t add_row [list "" $argdisplay_body] - } else { - if {$argdisplay_header ne ""} { - lappend errlines $argdisplay_header - } - lappend errlines {*}$argdisplay_body - } - } else { - - #set A_DEFAULT [a+ brightwhite Brightgreen] - set A_DEFAULT "" - set A_BADARG $CLR(badarg) - set A_GOODARG $CLR(goodarg) - set A_GOODCHOICE $CLR(goodchoice) - set greencheck $CLR(check)\u2713$RST ;#green tick - set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply - if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { - #A_PREFIX can resolve to empty string if colour off - #we then want to display underline instead - set A_PREFIX [a+ underline] - set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space - } else { - set A_PREFIXEND $RST - } - - #TODO - foreach fid - set fid [lindex $selected_forms 0] - set form_dict [dict get $spec_dict FORMS $fid] - - set opt_names [list] - set opt_names_display [list] - if {[llength [dict get $form_dict OPT_NAMES]]} { - if {![catch {package require punk::trie}]} { - set trie [punk::trie::trieclass new {*}[dict get $form_dict OPT_NAMES]] - set idents [dict get [$trie shortest_idents ""] scanned] - #todo - check opt_prefixdeny - - $trie destroy - foreach c [dict get $form_dict OPT_NAMES] { - set arginfo [dict get $form_dict ARG_INFO $c] - if {[dict get $arginfo -prefix]} { - set id [dict get $idents $c] - #REVIEW - if {$id eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $id] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail - } else { - lappend opt_names_display $c - } - #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] - lappend opt_names $c - } - } else { - set opt_names [dict get $form_dict OPT_NAMES] - set opt_names_display $opt_names - } - } - set leading_val_names [dict get $form_dict LEADER_NAMES] - set trailing_val_names [dict get $form_dict VAL_NAMES] - - #dict for {argname info} [tcl::dict::get $form_dict arg_info] { - # if {![string match -* $argname]} { - # lappend leading_val_names [lpop trailing_val_names 0] - # } else { - # break - # } - #} - #if {![llength $leading_val_names] && ![llength $opt_names]} { - # #all vals were actually trailing - no opts - # set trailing_val_names $leading_val_names - # set leading_val_names {} - #} - set leading_val_names_display $leading_val_names - set trailing_val_names_display $trailing_val_names - #puts "--> parsedargs: $parsedargs" - set parsed_leaders [Dict_getdef $parsedargs leaders {}] - set parsed_opts [Dict_getdef $parsedargs opts {}] - set parsed_values [Dict_getdef $parsedargs values {}] - - #display options first then values - foreach argumentset [list [list $leading_val_names_display $leading_val_names $parsed_leaders] [list $opt_names_display $opt_names $parsed_opts] [list $trailing_val_names_display $trailing_val_names $parsed_values]] { - lassign $argumentset argnames_display argnames parsedvalues - - foreach argshow $argnames_display arg $argnames { - set arginfo [dict get $form_dict ARG_INFO $arg] - if {[dict exists $arginfo -default]} { - set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" - } else { - set default "" - } - set help [Dict_getdef $arginfo -help ""] - set allchoices_originalcase [list] - set choices [Dict_getdef $arginfo -choices {}] - set choicegroups [Dict_getdef $arginfo -choicegroups {}] - set choicemultiple [dict get $arginfo -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] - set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] - if {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - set is_multiple 1 - } else { - set multiple "" - set is_multiple 0 - } - if {[dict exists $choicegroups ""]} { - dict lappend choicegroups "" {*}$choices - } else { - set choicegroups [dict merge [dict create "" $choices] $choicegroups] - } - dict for {groupname clist} $choicegroups { - lappend allchoices_originalcase {*}$clist - } - set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] - - if {$has_choices} { - if {$help ne ""} {append help \n} - if {[dict get $arginfo -nocase]} { - set casemsg " (case insensitive)" - set allchoices_test [string tolower $allchoices_originalcase] - } else { - set casemsg " (case sensitive)" - set allchoices_test $allchoices_originalcase - } - if {[dict get $arginfo -choiceprefix]} { - set prefixmsg " (choice prefix allowed)" - } else { - set prefixmsg "" - } - set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] - set choiceinfodict [Dict_getdef $arginfo -choiceinfo {}] - set formattedchoices [dict create] ;#use dict rather than array to preserve order - append help " Choices$prefixmsg$casemsg" - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - if {$choicemultiple_max == -1} { - append help \n " The value can be a list of $choicemultiple_min or more of these choices" - } else { - if {$choicemultiple_min eq $choicemultiple_max} { - append help \n " The value must be a list of $choicemultiple_min of these choices" - } else { - append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" - } - } - } - if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c [join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } else { - #set formattedchoices $choicegroups - #set formattedchoices [dict get $arginfo -choices] - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c [join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } - } else { - if {[catch { - set trie [punk::trie::trieclass new {*}$allchoices_test] - set idents [dict get [$trie shortest_idents ""] scanned] - if {[dict get $arginfo -nocase]} { - #idents were calculated on lcase - remap keys in idents to original casing - set actual_idents $idents - foreach ch $allchoices_originalcase { - if {![dict exists $idents $ch]} { - #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting - #The actual testing is done in get_dict - dict set actual_idents $ch [dict get $idents [string tolower $ch]] - } - } - set idents $actual_idents - #puts "-----" - #puts "idents $idents" - } - - $trie destroy - dict for {groupname clist} $choicegroups { - foreach c $clist { - if {$c in $choiceprefixdenylist} { - set shortestid $c - } else { - set shortestid [dict get $idents $c] - } - if {$shortestid eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $shortestid] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set mk " [join $markers {}]" - } else { - set mk "" - } - set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]$mk" - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - #puts "-- parsed:$parsedvalues arg:$arg c:$c" - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } errM]} { - #this failure can happen if -nocase is true and there are ambiguous entries - #e.g -nocase 1 -choices {x X} - puts stderr "prefix marking failed\n$errM" - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c [join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } else { - #set formattedchoices $choicegroups - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c[join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } - - } - } - set choicetable_objects [list] - set choicetable_footers [dict create] - dict for {groupname formatted} $formattedchoices { - set numcols $choicecolumns ;#todo - dynamic? - if {[llength $formatted] < $numcols} { - #don't show blank cells if single line of results - set numcols [llength $formatted] - } - if {$numcols > 0} { - if {$use_table} { - #risk of recursing - #TODO -title directly in list_as_table - set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] - lappend choicetable_objects $choicetableobj - $choicetableobj configure -title $CLR(groupname)$groupname - #append help \n[textblock::join -- " " [$choicetableobj print]] - } else { - if {$groupname ne ""} { - append help \n \n "$CLR(groupname)Group: $groupname$RST" - } else { - append help \n - } - append help \n [join $formatted \n] - } - } else { - #we were given an empty set of choices. - #probably an error in the definition - but could happen if dynamically generated. - #(e.g ensemble where unknown mechanism is used for subcommands?) - #better to just display that there were none rather than totally break the usage output. - if {$usetable} { - #these will be displayed after all table entries - if {$groupname eq ""} { - dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" - } else { - dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" - } - } else { - if {$groupname eq ""} { - append help \n " " $CLR(errormsg)(no choices defined)$RST - } else { - append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST - } - } - } - } - set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width - foreach obj $choicetable_objects { - dict lappend twidths_by_colcount [$obj column_count] [$obj width] - } - foreach obj $choicetable_objects { - set cols [$obj column_count] - set widths [dict get $twidths_by_colcount $cols] - set max [tcl::mathfunc::max {*}$widths] - $obj configure -minwidth $max ;#expand smaller ones - set i 0 - while {$i < $cols} { - #keep text aligned left on expanded tables - $obj configure_column $i -blockalign left - incr i - } - - append help \n[textblock::join -- " " [$obj print]] - #set ansititle [dict get [$obj configure -title] value] - $obj destroy - } - if {[dict size $choicetable_footers]} { - foreach groupname [dict keys $formattedchoices] { - if {[dict exists $choicetable_footers $groupname]} { - append help \n [dict get $choicetable_footers $groupname] - } - } - } - - #review. use -type to restrict additional choices - may be different to values in the -choices - if {![dict get $arginfo -choicerestricted]} { - #when -choicemultiple - the -type refers to each selection - if {[dict get $arginfo -type] eq "string"} { - append help "\n (values not in defined choices are allowed)" - } else { - append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" - } - } - } - if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { - if {$is_multiple} { - set argshow "?${argshow}...?" - } else { - set argshow "?${argshow}?" - } - } else { - if {$is_multiple} { - set argshow "${argshow}..." - } - } - set typeshow [dict get $arginfo -type] - if {$typeshow eq "none"} { - set typeshow "$typeshow $soloflag" - } - if {[dict exists $arginfo -minsize]} { - append typeshow \n "-minsize [dict get $arginfo -minsize]" - } - if {[dict exists $arginfo -maxsize]} { - append typeshow \n "-maxsize [dict get $arginfo -maxsize]" - } - if {[dict exists $arginfo -range]} { - append typeshow \n "-range [dict get $arginfo -range]" - } - - if {$use_table} { - $t add_row [list $argshow $typeshow $default $multiple $help] - if {$arg eq $badarg} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG - } elseif {$arg in $goodargs} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $A_GOODARG - } - } else { - #review - formatting will be all over the shop due to newlines in typesshow, help - set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" - if {$arg eq $badarg} { - set arghelp [punk::ansi::ansiwrap -rawansi $A_BADARG $arghelp] - } elseif {$arg in $goodargs} { - set arghelp [punk::ansi::ansiwrap -rawansi $A_GOODARG $arghelp] - } - foreach ln [split $help \n] { - append arghelp " $ln" \n - } - lappend errlines $arghelp - } - } - } - } ;#end is_custom_argdisplay - - if {$use_table} { - $t configure -show_hseps 0\ - -show_header 1\ - -ansibase_body $CLR(ansibase_body)\ - -ansibase_header $CLR(ansibase_header)\ - -ansiborder_header $CLR(ansiborder)\ - -ansiborder_body $CLR(ansiborder) - - $t configure -maxwidth 80 ;#review - if {$returntype ne "tableobject"} { - append errmsg [$t print] - #returntype of table means just the text of the table - $t destroy - } - } else { - append errmsg [join $errlines \n] - } - } errM]} { - catch {$t destroy} - append errmsg \n - append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n - append errmsg "$errM" \n - append errmsg "$::errorInfo" - - } - set arg_error_isrunning 0 - if {$use_table} { - #assert returntype is one of table, tableobject - set result $errmsg ;#default if for some reason table couldn't be used - if {$returntype eq "tableobject"} { - if {[info object isa object $t]} { - set result $t - } - } - } else { - set result $errmsg - } - if {$as_error} { - #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. - #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) - uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] - } else { - return $result - } - } - - - lappend PUNKARGS [list { - @dynamic - @id -id ::punk::args::usage - @cmd -name punk::args::usage -help\ - "Return usage information for a command identified by an id. - - This will only work for commands where a punk::args definition exists - for the command and an id has been defined for it. The id for custom - help for a command should match the fully qualified name of the command. - - Many commands (such as ensembles and oo objects) may have argument - documentation generated dynamically and may not yet have an id. - IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. - - Generally punk::ns::arginfo (aliased as i in the punk shell) should - be used in preference - as it will search for a documentation - mechanism and call punk::args::usage as necessary. - " - -return -default table -choices {string table tableobject} - }\ - {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}}\ - {${[punk::args::resolved_def -types opts ::punk::args::resolved_def -form]}}\ - { - - @values -min 0 -max 1 - id -help\ - "Exact id. - Will usually match the command name" - }] - proc usage {args} { - #lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received - lassign [dict values [punk::args::parse $args withid ::punk::args::usage]] leaders opts values received - set id [dict get $values id] - set real_id [real_id $id] - if {$real_id eq ""} { - error "punk::args::usage - no such id: $id" - } - #-scheme punk_info ?? - arg_error "" [punk::args::get_spec $real_id] {*}$opts -aserror 0 - } - - lappend PUNKARGS [list { - @id -id ::punk::args::get_by_id - @cmd -name punk::args::get_by_id - @values -min 1 - id - arglist -type list -help\ - "list containing arguments to be parsed as per the - argument specification identified by the supplied id." - }] - - - #deprecate? - proc get_by_id {id arglist} { - set definitionlist [punk::args::raw_def $id] - if {[llength $definitionlist] == 0} { - error "punk::args::get_by_id - no such id: $id" - } - #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] - tailcall ::punk::args::get_dict $definitionlist $arglist - } - - #consider - - #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) - #parse ?-flag val?... -- $arglist withid $id - #parse ?-flag val?... -- $arglist withdef $def ?$def?... - - #an experiment.. ideally we'd like arglist at the end? - #parse_withid ?-flag val?.. $id $arglist - #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? - #no possible equivalent for parse_withdef ??? - - lappend PUNKARGS [list { - @id -id ::punk::args::parse - @cmd -name punk::args::parse -help\ - "parse and validate command arguments based on a definition. - - In the 'withid' form the definition is a pre-existing record that has been - created with ::punk::args::define, or indirectly by adding a definition to - the PUNKARGS variable in a namespace which is then registered in - punk::args::register::NAMESPACES, or by a previous call to punk::parse - using 'withdef' and a definition block containing an @id -id directive. - - In the 'withdef' form - the definition is created on the first call and - cached thereafter, if the id didn't already exist. - - form1: parse $arglist ?-flag val?... withid $id - form2: parse $arglist ?-flag val?... withdef $def ?$def? - see punk::args::define - - Returns a dict of information regarding the parsed arguments - example of basic usage for single option only: - punk::args::define { - @id -id ::myns::myfunc - @cmd -name myns::myfunc - @leaders -min 0 -max 0 - @opts - -configfile -type existingfile - #type none makes it a solo flag - -verbose -type none - @values -min 0 -max 0 - } - proc myfunc {args} { - set argd [punk::args::parse $args withid ::myns::myfunc] - lassign [dict values $argd] leaders opts values received solos - if {[dict exists $received] -configfile} { - puts \"have option for existing file [dict get $opts -configfile]\" - } - } - The leaders, opts, values keys in the parse result dict are proper dicts. - The received key is dict-like but can have repeated keys for arguments than can - accept multiples. The value for each received element is the ordinal position. - The solos key refers to a list of solo flags received (those specified with - -type none). This is generally only useful to assist in passing arguments on - to another procedure which also requires solos, because the opts dict contains - solo flags with a 1 value or a list of 1's if it was a solo with -multiple true - specified. - " - @form -form {withid withdef} - @leaders -min 1 -max 1 - arglist -type list -optional 0 -help\ - "Arguments to parse - supplied as a single list" - - @opts - -form -type list -default * -help\ - "Restrict parsing to the set of forms listed. - Forms are the orthogonal sets of arguments a - command can take - usually described in 'synopsis' - entries." - #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance - #todo - configurable per interp/namespace - -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} - - @values -min 2 - - @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" - @values -max 2 - withid -type literal -help\ - "The literal value 'withid'" - id -type string -help\ - "id of punk::args definition for a command" - - - @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" - withdef -type literal -help\ - "The literal value 'withdef'" - - #todo - make -dynamic obsolete - use @dynamic directive instead - def -type string -multiple 1 -optional 0 -help\ - "Each remaining argument is a block of text - defining argument definitions. - As a special case, -dynamic may be - specified as the 1st 2 arguments. These are - treated as an indicator to punk::args about - how to process the definition." - - }] - proc parse {args} { - set tailtype "" ;#withid|withdef - if {[llength $args] < 3} { - #error "punk::args::parse - invalid call. < 3 args" - punk::args::parse $args withid ::punk::args::parse - } - set opts_and_vals $args - set parseargs [lpop opts_and_vals 0] - - set opts [list] - set values [list] - for {set i 0} {$i < [llength $opts_and_vals]} {incr i} { - if {[string match -* [lindex $opts_and_vals $i]]} { - if {[catch { - lappend opts [lpop opts_and_vals 0] [lpop opts_and_vals 0] - }]} { - #unhappy path - not enough options - #review - which form of punk::args::parse? - punk::args::parse $args withid ::punk::args::parse - } - incr i -1 - #lappend opts $a [lindex $opts_and_vals $i] - } else { - break - } - } - #set values [lrange $opts_and_vals $i end] - set values $opts_and_vals - #puts "---values: $values" - set tailtype [lindex $values 0] - set tailargs [lrange $values 1 end] - - - #set split [lsearch -exact $tailargs withid] - #if {$split < 0} { - # set split [lsearch -exact $tailargs withdef] - # if {$split < 0} { - # #punk::args::usage arg_error? - # #error "punk::args::parse - invalid call. keyword withid|withdef required" - # punk::args::parse $args withid ::punk::args::parse - # } else { - # set tailtype withdef - #} - #} else { - # set tailtype withid - #} - #set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. - - - #if {[llength $opts] % 2} { - #error "punk::args::parse Even number of -flag val pairs required after arglist" - #} - - #Default the -errorstyle to enhanced - # (slowest on unhappy path - but probably clearest for playing with new APIs interactively) - # - application devs should distribute a config file with an errorstyle override if desired. - # - devs who prefer a different default for interactive use should create a config for it. (todo) - set defaultopts [dict create\ - -form {*}\ - -errorstyle enhanced\ - ] - - #todo - load override_errorstyle from configuration - #dict set defaultopts -errorstyle $ - #puts "def: $defaultopts opts: $opts" - set opts [dict merge $defaultopts $opts] - dict for {k v} $opts { - switch -- $k { - -form - -errorstyle { - } - default { - #punk::args::usage $args withid ::punk::args::parse ?? - #error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" - punk::args::parse $args withid ::punk::args::parse - } - } - } - switch -- $tailtype { - withid { - if {[llength $tailargs] != 1} { - #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - punk::args::parse $args withid ::punk::args::parse - } - set id [lindex $tailargs 0] - #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" - set deflist [raw_def $id] - if {[llength $deflist] == 0} { - error "punk::args::parse - no such id: $id" - } - } - withdef { - set deflist $tailargs - if {[llength $deflist] < 1} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" - } - default { - error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" - } - } - try { - set result [punk::args::get_dict $deflist $parseargs -form [dict get $opts -form]] - } trap {PUNKARGS VALIDATION} {msg erroropts} { - set opt_errorstyle [dict get $opts -errorstyle] - - #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - - - set ecode [dict get $erroropts -errorcode] - #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... - set msg [string map [list %caller% [Get_caller]] $msg] - switch -- $opt_errorstyle { - minimal { - return -options [list -code error -errorcode $ecode] $msg - } - basic { - #No table layout - unix manpage style - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg -form [dict get $opts -form]] - } - return -options [list -code error -errorcode $ecode] $msg - } - standard { - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] - } - return -options [list -code error -errorcode $ecode] $msg - } - enhanced { - set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below) - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - set ecode_summary [lrange $ecode 0 2] - if {$badarg ne ""} { - lappend ecode_summary -badarg $badarg - } - catch {package require punk::lib} - if {[package provide punk::lib] ne ""} { - append msg \n [punk::lib::showdict -roottype list $estack */*] - } - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] - append msg \n "::errorCode summary: $ecode_summary" - return -options [list -code error -errorcode $ecode] $msg - } else { - #why? todo? - append msg \n "(enhanced error information unavailable)" - append msg \n "::errorCode summary: $ecode_summary" - return -options [list -code error -errorcode $ecode] $msg - } - } - debug { - puts stderr "errorstyle debug not implemented" - return -options [list -code error -errorcode $ecode] $msg - } - default { - puts stderr "errorstyle $opt_errorstyle not recognised: expected one of minimal basic standard enhanced debug" - return -options [list -code error -errorcode $ecode] $msg - } - } - } trap {PUNKARGS} {msg erropts} { - append msg \n "Unexpected PUNKARGS error" - return -options [list -code error -errorcode $ecode] $msg - } trap {} {msg erroropts} { - #review - #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. - #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. - throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] - } - return $result - } - proc parseXXX {args} { - #no solo flags allowed for parse function itself. (ok for arglist being parsed) - set opts [dict create] ;#repeated flags will override earlier. That's ok here. - set arglist {} - set got_arglist 0 - set tailtype "" ;#withid|withdef - set id "" - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {[string match -* $a]} { - dict set opts $a [lindex $args $i+1] - incr i - } else { - set arglist $a - set got_arglist 1 - set tailtype [lindex $args $i+1] - if {$tailtype eq "withid"} { - if {[llength $args] != $i+3} { - error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - } - set id [lindex $args $i+2] - break - } elseif {$tailtype eq "withdef"} { - if {[llength $args] < $i+3} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - set deflist [lrange $args $i+2 end] - break - } else { - error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" - } - } - } - if {!$got_arglist} { - error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." - } - #assert tailtype eq withid|withdef - if {$tailtype eq "withid"} { - #assert $id was provided - return "parse [llength $arglist] args withid $id, options:$opts" - } else { - #assert llength deflist >=1 - return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" - } - #TODO - } - - #todo? - a version of get_dict that directly supports punk::lib::tstr templating - #rename get_dict - # - - #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 get_dict {deflist rawargs args} { - #see arg_error regarding considerations around unhappy-path performance - - if {[llength $args] % 2 != 0} { - error "punk::args::get_dict args must be a dict of option value pairs" - } - set defaults [dict create\ - -form *\ - ] - set opts [dict merge $defaults $args] - dict for {k v} $opts { - switch -- $k { - -form {} - default { - error "punk::args::get_dict Unexpected option '$k' Known options -form" - } - } - } - - - #*** !doctools - #[call [fun get_dict] [arg deflist] [arg rawargs] [arg args]] - #[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 values - #[para]ARGUMENTS: - #[list_begin arguments] - #[arg_def list-of-multiline-string deflist] - #[para] These are blocks 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 defining a flag 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 - #[para]Each optionspec line defining a positional argument is of the form: - #[para]argumentname -key val -ky2 val2... - #[para]where the valid keys for each option specification are: -default -type -range -choices - #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value - #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. - #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. - #[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, - #but it could be a manually constructed list of values made for example from positional args defined in the proc. - #[list_end] - #[para] - - #consider line-processing example below for which we need info complete to determine record boundaries - #punk::args::get_dict [list { - # @opts - # -opt1 -default {} - # -opt2 -default { - # etc - # } - # @values -multiple 1 - #}] $args - - - - - #rawargs: args values to be parsed - #we take a definition list rather than resolved argspecs - because the definition could be dynamic - - #if definition has been seen before, - #define will either return a permanently cached argspecs (-dynamic 0) - or - # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. - set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]] - - # ----------------------------------------------- - # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) - tcl::dict::with argspecs {} ;#turn keys into vars - #e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info,id_info,form_names - # ----------------------------------------------- - set opt_form [dict get $opts -form] - if {$opt_form eq "*"} { - set selected_forms $form_names - } elseif {[string is integer -strict $opt_form]} { - if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { - error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set selected_forms [list [lindex $form_names $opt_form]] - } else { - if {$opt_form ni $form_names} { - error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set selected_forms [list $opt_form] - } - - - #puts "-arg_info->$arg_info" - set flagsreceived [list] ;#for checking if required flags satisfied - set solosreceived [list] - set multisreceived [list] - #secondary purpose: - #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 ? - - # -- --- --- --- - # Handle leading positionals - # todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ? - - #todo - handle multiple fids? - set fid [lindex $selected_forms 0] - set formdict [dict get $FORMS $fid] - tcl::dict::with formdict {} - #populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc - if {$VAL_MIN eq ""} { - set valmin 0 - set VAL_MIN 0 - } else { - set valmin $VAL_MIN - } - - set pre_values {} - - set argnames [tcl::dict::keys $ARG_INFO] - set optnames [lsearch -all -inline $argnames -*] - set ridx 0 - set rawargs_copy $rawargs - set leader_posn_name "" - set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) - set is_multiple 0 ;#last leader may be multi - if {$LEADER_MAX != 0} { - foreach r $rawargs_copy { - if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { - break - } - if {$ridx == [llength $LEADER_NAMES]-1} { - #at last named leader - set leader_posn_name [lindex $LEADER_NAMES $ridx] - if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { - set is_multiple 1 - } - } elseif {$ridx > [llength $LEADER_NAMES]-1} { - #beyond names - retain name if -multiple was true - if {!$is_multiple} { - set leader_posn_name "" - } - } else { - set leader_posn_name [lindex $LEADER_NAMES $ridx] ;#may return empty string - } - if {$r eq "--"} { - #review end of opts marker: '--' can't be a leader (but can be a value) - break - } - - #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option - if {[tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { - set matchopt [::tcl::prefix::match -error {} $optnames $r] - if {$matchopt ne ""} { - #flaglike matches a known flag - don't treat as leader - break - } - #if {![string match -* [lindex $argnames $ridx]]} {} - if {$leader_posn_name ne ""} { - #there is a named leading positional for this position - #The flaglooking value doesn't match an option - so treat as a leader - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - incr ridx - continue - } else { - break - } - } - - #for each branch - break or lappend - if {$leader_posn_name ne ""} { - if {$leader_posn_name ni $LEADER_REQUIRED} { - #optional leader - - #most adhoc arg processing will allocate based on number of args rather than matching choice values first - #(because a choice value could be a legitimate data value) - - #review - option to process in this manner? - #first check if the optional leader value is a match for a choice ? - #if {[dict exists $arg_info $leader_posn_name -choices]} { - # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] [lindex $rawargs 0]] - # if {$vmatch ne ""} { - # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values - # lappend pre_values [lpop rawargs 0] - # incr ridx - # continue - # } - #} - - #check if enough rawargs to fill any required values - if {$VAL_MIN > 0 && [llength $rawargs] <= $VAL_MIN || [llength $rawargs] <= [llength $VAL_REQUIRED]} { - break - } else { - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #required - if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { - #already accepted at least one value - requirement satisfied - now equivalent to optional - if {$VAL_MIN > 0 && [llength $rawargs] <= $VAL_MIN || [llength $rawargs] <= [llength $VAL_REQUIRED]} { - break - } - } - #if we didn't break - requirement is not yet satisfied, or is satisfied but stil enough rawargs for required values - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #unnamed leader - if {$LEADER_MIN ne "" } { - if {$ridx > $LEADER_MIN-1} { - if {$LEADER_MAX ne "" && $ridx == $LEADER_MAX} { - break - } else { - if {$VAL_MIN ne ""} { - if {[llength $rawargs] > $VAL_MIN} { - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } else { - break - } - } else { - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } - } else { - #haven't reached LEADER_MIN - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - break - } - } - - incr ridx - } ;# end foreach r $rawargs_copy - } - - set argstate $ARG_INFO ;#argstate may have entries added - set arg_checks $ARG_CHECKS - - #JJJJ - if {$LEADER_MIN eq ""} { - set leadermin 0 - } else { - set leadermin $LEADER_MIN - } - if {$LEADER_MAX eq ""} { - set leadermax -1 - } else { - set leadermax $LEADER_MAX - } - - if {$VAL_MAX eq ""} { - set valmax -1 - } else { - set valmax $VAL_MAX - } - - #assert leadermax leadermin are numeric - #assert - rawargs has been reduced by leading positionals - - set opts [dict create] ;#don't set to OPT_DEFAULTS here - - - set leaders [list] - set arglist {} - set post_values {} - #valmin, valmax - #puts stderr "rawargs: $rawargs" - #puts stderr "argstate: $argstate" - if {[lsearch $rawargs -*] >= 0} { - #at least contains flaglike things.. - set maxidx [expr {[llength $rawargs] -1}] - if {$valmax == -1} { - set vals_total_possible [llength $rawargs] - set vals_remaining_possible $vals_total_possible - } else { - set vals_total_possible $valmax - set vals_remaining_possible $vals_total_possible - } - for {set i 0} {$i <= $maxidx} {incr i} { - set a [lindex $rawargs $i] - set remaining_args_including_this [expr {[llength $rawargs] - $i}] - #lowest valmin is 0 - if {$remaining_args_including_this <= $valmin} { - # if current arg is -- it will pass through as a value here - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - - #exlude argument with whitespace from being a possible option e.g dict - if {[tcl::string::match -* $a] && !([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { - if {$a eq "--"} { - #remaining num args <= valmin already covered above - if {$valmax != -1} { - #finite max number of vals - if {$remaining_args_including_this == $valmax} { - #assume it's a value. - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - } else { - #assume it's an end-of-options marker - lappend flagsreceived -- - set arglist [lrange $rawargs 0 $i] - set post_values [lrange $rawargs $i+1 end] - } - } else { - #unlimited number of post_values accepted - #treat this as eopts - we don't care if remainder look like options or not - lappend flagsreceived -- - set arglist [lrange $rawargs 0 $i] - set post_values [lrange $rawargs $i+1 end] - } - break - } else { - set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] - if {$fullopt ne ""} { - if {![tcl::dict::get $argstate $fullopt -prefix] && $a ne $fullopt} { - #attempt to use a prefix when not allowed - #review - by ending opts here - we dont' get the clearest error msgs - # may *sometimes* be better to raise a PUNKARGS VALIDATION (invalidoption) error - # (but it may actually be the first value that just happens to be flaglike) - #todo - check for subsequent valid flags or -- marker? - #consider for example 'file delete -f -- old.txt' - #If we just end option-processing, the punk::args parser would pass {-f -- old.txt} as values - #whereas the builtin file arg parser alerts that -f is a bad option - set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg - #set arglist [lrange $rawargs 0 $i-1] - #set post_values [lrange $rawargs $i end] - #break - } - if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { - #non-solo - #check if it was actually a value that looked like a flag - if {$i == $maxidx} { - #if no optvalue following - assume it's a value - #(caller should probably have used -- before it) - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - - set flagval [lindex $rawargs $i+1] - if {[tcl::dict::get $argstate $fullopt -multiple]} { - #don't lappend to default - we need to replace if there is a default - if {$fullopt ni $flagsreceived} { - tcl::dict::set opts $fullopt [list $flagval] - } else { - tcl::dict::lappend opts $fullopt $flagval - } - if {$fullopt ni $multisreceived} { - lappend multisreceived $fullopt - } - } else { - tcl::dict::set opts $fullopt $flagval - } - #incr i to skip flagval - incr vals_remaining_possible -2 - if {[incr i] > $maxidx} { - set msg "Bad options for %caller%. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $fullopt index [expr {$i-1}]] -badarg $fullopt -argspecs $argspecs]] $msg - } - } else { - #solo - if {[tcl::dict::get $argstate $fullopt -multiple]} { - if {$fullopt ni $flagsreceived} { - #override any default - don't lappend to it - tcl::dict::set opts $fullopt 1 - } else { - tcl::dict::lappend opts $fullopt 1 - } - if {$fullopt ni $multisreceived} { - lappend multisreceived $fullopt - } - } else { - tcl::dict::set opts $fullopt 1 - } - incr vals_remaining_possible -1 - lappend solosreceived $fullopt ;#dups ok - } - lappend flagsreceived $fullopt ;#dups ok - } else { - #unmatched option flag - #comparison to valmin already done above - if {$valmax ne -1 && $remaining_args_including_this <= $valmax} { - #todo - look at optspec_default and see if solo/vs opt-val pair - #we may need to lookahead by 2 regarding valmax valmin - - #even with optany - assume an unknown within the space of possible values is a value - #unmatched option in right position to be considered a value - treat like eopts - #review - document that an unspecified arg within range of possible values will act like eopts -- - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - if {$OPT_ANY} { - set newval [lindex $rawargs $i+1] - #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option - tcl::dict::set argstate $a $OPTSPEC_DEFAULTS ;#use default settings for unspecified opt - tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS - if {[tcl::dict::get $argstate $a -type] ne "none"} { - if {[tcl::dict::get $argstate $a -multiple]} { - tcl::dict::lappend opts $a $newval - if {$a ni $multisreceived} { - lappend multisreceived $a - } - } else { - tcl::dict::set opts $a $newval - } - if {[incr i] > $maxidx} { - set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg - #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a - } - incr vals_remaining_possible -2 - } else { - #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none - if {[tcl::dict::get $argstate $a -multiple]} { - if {![tcl::dict::exists $opts $a]} { - tcl::dict::set opts $a 1 - } else { - tcl::dict::lappend opts $a 1 - } - if {$a ni $multisreceived} { - lappend multisreceived $a - } - } else { - tcl::dict::set opts $a 1 - } - incr vals_remaining_possible -1 - lappend solosreceived $a - } - lappend flagsreceived $a ;#adhoc flag as supplied - } else { - if {[llength $OPT_NAMES]} { - set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" - } else { - set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any 0" - } - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg - #arg_error $errmsg $argspecs -badarg $fullopt - } - } - } - } else { - #not flaglike - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - } - #set values [list {*}$pre_values {*}$post_values] - set leaders $pre_values - set values $post_values - } else { - set leaders $pre_values - set values $rawargs - #set values [list {*}$pre_values {*}$rawargs] ;#no -flags detected - set arglist [list] - } - #puts stderr "--> arglist: $arglist" - #puts stderr "--> values: $values" - - #--------------------------------------- - set ordered_opts [dict create] - foreach o $OPT_NAMES { - if {[dict exists $opts $o]} { - dict set ordered_opts $o [dict get $opts $o] - } elseif {[dict exists $OPT_DEFAULTS $o]} { - dict set ordered_opts $o [dict get $OPT_DEFAULTS $o] - } - } - #add in possible '-any true' opts after the defined opts - dict for {o oval} $opts { - if {![dict exists $ordered_opts $o]} { - dict set ordered_opts $o $oval - } - } - set opts $ordered_opts - #--------------------------------------- - - - set positionalidx 0 ;#index for unnamed positionals (both leaders and values) - set ldridx 0 - set in_multiple "" - set leadernames_received [list] - - set num_leaders [llength $leaders] - #---------------------------------------- - #set leaders_dict $LEADER_DEFAULTS ;#wrong - set leaders_dict [dict create] - foreach lname [lrange $LEADER_NAMES 0 $num_leaders-1] { - dict set leaders_dict $lname {} - } - set leaders_dict [dict merge $leaders_dict $LEADER_DEFAULTS] - #---------------------------------------- - - foreach leadername $LEADER_NAMES ldr $leaders { - if {$ldridx+1 > $num_leaders} { - break - } - if {$leadername ne ""} { - if {[tcl::dict::get $argstate $leadername -multiple]} { - if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { - tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list - } else { - tcl::dict::lappend leaders_dict $leadername $ldr - } - set in_multiple $leadername - } else { - tcl::dict::set leaders_dict $leadername $ldr - } - lappend leadernames_received $leadername - } else { - if {$in_multiple ne ""} { - tcl::dict::lappend leaders_dict $in_multiple $ldr - lappend leadernames_received $in_multiple ;#deliberately allow dups! (as with opts and values) - } else { - tcl::dict::set leaders_dict $positionalidx $ldr - tcl::dict::set argstate $positionalidx $LEADERSPEC_DEFAULTS - tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS - lappend leadernames_received $positionalidx - } - } - incr ldridx - incr positionalidx - } - - - set validx 0 - set valname_multiple "" - set valnames_received [list] - - set num_values [llength $values] - #------------------------------------------ - #!!! review - ## Don't set values_dict to VAL_DEFAULTS - or order of values_dict will be intermittently wrong based on whether values have defaults - ## set values_dict $val_defaults - set values_dict [dict create] - foreach valname [lrange $VAL_NAMES 0 $num_values-1] { - dict set values_dict $valname {} - } - set values_dict [dict merge $values_dict $VAL_DEFAULTS] - #------------------------------------------ - set nameidx 0 - set start_position $positionalidx - for {set validx 0} {$validx < [llength $values]} {incr validx} { - set valname [lindex $VAL_NAMES $nameidx] - incr nameidx - set val [lindex $values $validx] - if {$valname ne ""} { - if {[llength $valname] == 1} { - set strideval $val - } else { - set strideval [list] - incr validx -1 - foreach v $valname { - incr validx - if {$validx > [llength $values]-1} { - set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname', but requires [llength $valname] values." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname] ] -argspecs $argspecs]] $msg - } - lappend strideval [lindex $values $validx] - } - } - - if {[tcl::dict::get $argstate $valname -multiple]} { - if {[tcl::dict::exists $VAL_DEFAULTS $valname]} { - #current stored val equals defined default - don't include default in the list we build up - tcl::dict::set values_dict $valname [list $strideval] ;#important to treat first element as a list - } else { - tcl::dict::lappend values_dict $valname $strideval - } - set valname_multiple $valname - } else { - tcl::dict::set values_dict $valname $strideval - } - lappend valnames_received $valname - } else { - if {$valname_multiple ne ""} { - if {[llength $valname_multiple] == 1} { - set strideval $val - } else { - set strideval [list] - incr validx -1 - foreach v $valname_multiple { - incr validx - if {$validx > [llength $values]-1} { - set msg "Bad number of values for %caller%. Received [llength $strideval] values for '$valname_multiple', but requires [llength $valname_multiple] values." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list stridevaluecount [llength $strideval] stride [llength $valname_multiple] ] -argspecs $argspecs]] $msg - } - lappend strideval [lindex $values $validx] - } - } - tcl::dict::lappend values_dict $valname_multiple $strideval - #name already seen - but must add to valnames_received anyway (as with opts and leaders) - lappend valnames_received $valname_multiple - } else { - tcl::dict::set values_dict $positionalidx $val - tcl::dict::set argstate $positionalidx $VALSPEC_DEFAULTS - tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS - lappend valnames_received $positionalidx - } - } - set positionalidx [expr {$start_position + $validx}] - } - #------------------------------------------ - - if {$leadermax == -1} { - #only check min - if {$num_leaders < $leadermin} { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected at least $leadermin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - } - } else { - if {$num_leaders < $leadermin || $num_leaders > $leadermax} { - if {$leadermin == $leadermax} { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected exactly $leadermin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - } else { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - } - } - } - - if {$valmax == -1} { - #only check min - if {$num_values < $valmin} { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $valmin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg - } - } else { - if {$num_values < $valmin || $num_values > $valmax} { - if {$valmin == $valmax} { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $valmin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg - } else { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $valmin and $valmax inclusive" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg - } - } - } - - #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options - - - #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 SHOULD? 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 - - #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? - #example timing difference: - #struct::set difference {x} {a b} - #normal interp 0.18 u2 vs safe interp 9.4us - #if {[llength [set missing [struct::set difference $OPT_REQUIRED $flagsreceived]]]} { - # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" - #} - #if {[llength [set missing [struct::set difference $VAL_REQUIRED $valnames_received]]]} { - # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" - #} - #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us - if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { - set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadermissing $missing received $leadernames_received] -argspecs $argspecs]] $msg - #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - if {[llength [set missing [punklib_ldiff $OPT_REQUIRED $flagsreceived]]]} { - set msg "Required option missing for %caller%. missing flags: '$missing' are marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list optionmissing $missing received $flagsreceived] -argspecs $argspecs]] $msg - #arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs - } - if {[llength [set missing [punklib_ldiff $VAL_REQUIRED $valnames_received]]]} { - set msg "Required value missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list valuemissing $missing received $valnames_received] -argspecs $argspecs]] $msg - #arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - - - #todo - truncate/summarize values in error messages - - #todo - allow defaults outside of choices/ranges - - #check types,ranges,choices - set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] - #set combined_defaults [tcl::dict::merge $VAL_DEFAULTS $OPT_DEFAULTS] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash - #puts "---opts_and_values:$opts_and_values" - #puts "---argstate:$argstate" - tcl::dict::for {argname v} $opts_and_values { - set thisarg [tcl::dict::get $argstate $argname] - #set thisarg_keys [tcl::dict::keys $thisarg] - set thisarg_checks [tcl::dict::get $arg_checks $argname] - set is_multiple [tcl::dict::get $thisarg -multiple] - set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] - set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] - set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] - set has_default [tcl::dict::exists $thisarg -default] - if {$has_default} { - set defaultval [tcl::dict::get $thisarg -default] - } - set type [tcl::dict::get $thisarg -type] - set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] - set regexprepass [tcl::dict::get $thisarg -regexprepass] - set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 - set validationtransform [tcl::dict::get $thisarg -validationtransform] - - - if {$is_multiple} { - set vlist $v - } else { - set vlist [list $v] - } - set vlist_original $vlist ;#retain for possible final strip_ansi - - #review - validationtransform - if {$is_validate_ansistripped} { - #validate_ansistripped 1 - package require punk::ansi - set vlist_check [list] - foreach e $vlist { - lappend vlist_check [punk::ansi::ansistrip $e] - } - } else { - #validate_ansistripped 0 - set vlist_check $vlist - } - - switch -- [Dict_getdef $thisarg -ARGTYPE unknown] { - leader { - set dname leaders_dict - set argclass "Leading argument" - } - option { - set dname opts - set argclass Option - } - value { - set dname values_dict - set argclass "Trailing argument" - } - default { - set dname "_unknown_" ;#NA - set argclass "Unknown argument" - } - } - #reduce our validation requirements by removing values which match defaultval or match -choices - #(could be -multiple with -choicerestriction 0 where some selections match and others don't) - if {$has_choices} { - #-choices must also work with -multiple - #todo -choicelabels - set choiceprefix [tcl::dict::get $thisarg -choiceprefix] - set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] - set choicerestricted [tcl::dict::get $thisarg -choicerestricted] - set choicemultiple [tcl::dict::get $thisarg -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set nocase [tcl::dict::get $thisarg -nocase] - set choices [Dict_getdef $thisarg -choices {}] - set choicegroups [Dict_getdef $thisarg -choicegroups {}] - set allchoices $choices - if {[dict size $choicegroups]} { - dict for {groupname groupmembers} $choicegroups { - lappend allchoices {*}$groupmembers - } - } - #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups - #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes - - - set idx 0 ;# - #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes - #assert llength $vlist == llength [dict get $dname $argname] - # (unless there was a default and the option wasn't specified) - set vlist_validate [list] - set vlist_check_validate [list] - foreach e $vlist e_check $vlist_check { - set allchoices_in_list 0 - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - #vlist and vlist_check can be list of lists if -multiple and -choicemultiple - #each e represents 0 or more choice selections - set c_list $e - set c_check_list $e_check - #todo? check if entire list matches default? - } else { - #only one choice at a time - ensure single entry in c_list c_check_list - set c_list [list $e] - set c_check_list [list $e_check] - } - - - #----------------------------------- - #fast fail on the wrong number of choices - if {[llength $c_list] < $choicemultiple_min} { - set msg "$argclass $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { - set msg "$argclass $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - #----------------------------------- - - set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list - foreach c $c_list c_check $c_check_list { - if {$nocase} { - set casemsg " (case insensitive)" - set choices_test [tcl::string::tolower $allchoices] - #Don't lcase the denylist - even in nocase mode! - #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] - set v_test [tcl::string::tolower $c_check] - } else { - set casemsg " (case sensitive)" - set v_test $c_check - set choices_test $allchoices - } - set choice_in_list 0 - set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? - if {!$matches_default} { - if {$choiceprefix} { - #can we handle empty string as a choice? It should just work - REVIEW/test - set choice_exact_match 0 - if {$c_check in $allchoices} { - #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing - set chosen $c_check - set choice_in_list 1 - set choice_exact_match 1 - } elseif {$v_test in $choices_test} { - #assert - if we're here, nocase must be true - #we know choice is present as full-length match except for case - #now we want to select the case from the choice list - not the supplied value - #we don't set choice_exact_match - because we will need to override the optimistic existing val below - #review - foreach avail [lsort -unique $allchoices] { - if {[string match -nocase $c $avail]} { - set chosen $avail - } - } - #assert chosen will always get set - set choice_in_list 1 - } else { - #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. - #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. - #in this block we can treat empty result from prefix match as a non-match - if {$nocase} { - #nocase implies that our entered value doesn't have to match case of choices - - #but we would still like to select the best match if there are case-dups. - #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete - # selecting Del will find Delete, del will match delete (and raise error) - # but DEL will also match delete rather than Delete - so again an error is raised. - #This is counterintuitive with -nocase - #This is probably such an edge case that best served with documentation as a feature-not-bug - #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? - #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. - - set bestmatch [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] - if {$bestmatch eq ""} { - set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] - #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing - set chosen [lsearch -inline -nocase $allchoices $chosen] - set choice_in_list [expr {$chosen ne ""}] - } else { - set chosen $bestmatch - set choice_in_list 1 - } - } else { - set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $c_check] - if {$chosen eq ""} { - set choice_in_list 0 - } else { - set choice_in_list 1 - } - } - #override choice_in_list if in deny list - #don't allow prefixing for elements from -choiceprefixdenylist - #we still use all elements to calculate the prefixes though - #review - case difference edge cases in choiceprefixdenylist !todo - if {$chosen in $choiceprefixdenylist} { - set choice_in_list 0 - set chosen "" - } - } - - #override the optimistic existing val - if {$choice_in_list && !$choice_exact_match} { - if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { - if {$is_multiple} { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $idx $chosen - tcl::dict::set $dname $argname $existing - } else { - tcl::dict::set $dname $argname $chosen - } - } else { - if {$is_multiple} { - set existing_all [tcl::dict::get [set $dname] $argname] - lset existing_all $idx $choice_idx $chosen - tcl::dict::set $dname $argname $existing_all - } else { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $choice_idx $chosen - tcl::dict::set $dname $argname $existing - } - } - } - } else { - #value as stored in $dname is ok - set choice_in_list [expr {$v_test in $choices_test}] - } - } - - if {!$choice_in_list && !$matches_default} { - if {!$choicerestricted} { - #if {$is_multiple} { - # set existing [tcl::dict::get [set $dname] $argname] - # lset existing $idx $v_test - # tcl::dict::set $dname $argname $existing - #} else { - # tcl::dict::set $dname $argname $v_test - #} - lappend vlist_validate $c - lappend vlist_check_validate $c_check - } else { - #unhappy path - if {$choiceprefix} { - set prefixmsg " (or a unique prefix of a value)" - } else { - set prefixmsg "" - } - #review: $c vs $c_check for -badval? - set msg "$argclass '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname - } - } - incr choice_idx - } - - incr idx - } - #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation - #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - - if {[llength $vlist] && $has_default} { - set vlist_validate [list] - set vlist_check_validate [list] - foreach c $vlist c_check $vlist_check { - #for -choicemultiple with default that could be a list use 'ni' ?? review - if {$c_check ne $defaultval} { - lappend vlist_validate $c - lappend vlist_check_validate $c - } - } - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - - #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups - #assert: our vlist & vlist_check lists have been reduced to remove those - if {[llength $vlist] && !$is_allow_ansi} { - #allow_ansi 0 - package require punk::ansi - #do not run ta::detect on a list - foreach e $vlist { - if {[punk::ansi::ta::detect $e]} { - set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - #puts "argname:$argname v:$v is_default:$is_default" - #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. - #arguments that are at their default are not subject to type and other checks - - #don't validate defaults or choices that matched - #puts "---> opts_and_values: $opts_and_values" - #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" - #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} - - #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups - #assert [llength $vlist] == [llength $vlist_check] - if {[llength $vlist]} { - switch -- $type { - literal { - foreach e $vlist { - if {$e ne $argname} { - set msg "$argclass '$argname' for %caller% requires literal value '$argname'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - } - } - } - any {} - list { - foreach e_check $vlist_check { - if {![tcl::string::is list -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[llength $e_check] < $checkval} { - set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[llength $e_check] > $checkval} { - set msg "$argclass '$argname for %caller% requires list with -maxsize $checkval. Received len:[llength $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - } - indexexpression { - foreach e_check $vlist_check { - if {[catch {lindex {} $e_check}]} { - set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - string - ansistring - globstring { - #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string - #we possibly don't want to always have to regex on things that don't pass the other more basic checks - # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) - # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) - # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead - # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function - # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) - # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail - - #todo? - way to validate both unstripped and stripped? - set pass_quick_list_e [list] - set pass_quick_list_e_check [list] - set remaining_e $vlist - set remaining_e_check $vlist_check - #review - order of -regexprepass and -regexprefail in original rawargs significant? - #for now -regexprepass always takes precedence - if {$regexprepass ne ""} { - foreach e $vlist e_check $vlist_check { - if {[regexp $regexprepass $e]} { - lappend pass_quick_list_e $e - lappend pass_quick_list_e_check $e_check - } - } - set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] - set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] - } - if {$regexprefail ne ""} { - foreach e $remaining_e e_check $remaining_e_check { - #puts "----> checking $e vs regex $regexprefail" - if {[regexp $regexprefail $e]} { - if {[tcl::dict::exists $thisarg -regexprefailmsg]} { - #review - %caller% ?? - set msg [tcl::dict::get $thisarg -regexprefailmsg] - } else { - set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" - } - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $e -argspecs $argspecs]] $msg - } - } - } - switch -- $type { - ansistring { - #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi - #.. so we need to look at the original values in $vlist not $vlist_check - - #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? - #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? - package require punk::ansi - foreach e $remaining_e { - if {![punk::ansi::ta::detect $e]} { - set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - } - } - } - globstring { - foreach e $remaining_e { - if {![regexp {[*?\[\]]} $e]} { - set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - } - } - } - } - - if {[tcl::dict::size $thisarg_checks]} { - foreach e_check $remaining_e_check { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[tcl::string::length $e_check] < $checkval} { - set msg "$argclass '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::string::length $e_check] > $checkval} { - set msg "$argclass '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - } - number { - #review - consider effects of Nan and Inf - #NaN can be considered as 'technically' a number (or at least a special numeric value) - lassign {} low high ;#set both empty - set has_range 0 - if {[tcl::dict::exists $thisarg -range]} { - lassign [tcl::dict::get $thisarg -range] low high - if {"$low$high" ne ""} { - set has_range 1 - } - } - foreach e $vlist e_check $vlist_check { - if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} { - set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - if {$has_range} { - if {[::tcl::mathfunc::isnan $e]} { - set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - if {$low eq ""} { - if {$e_check > $high} { - set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } elseif {$high eq ""} { - if {$e_check < $low} { - set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } else { - if {$e_check < $low || $e_check > $high} { - set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - int { - #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive - if {[tcl::dict::exists $thisarg -range]} { - lassign [tcl::dict::get $thisarg -range] low high - if {"$low$high" ne ""} { - if {$low eq ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - #lowside unspecified - check only high - if {$e_check > $high} { - set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } elseif {$high eq ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - #highside unspecified - check only low - if {$e_check < $low} { - set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } else { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - #high and low specified - if {$e_check < $low || $e_check > $high} { - set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } else { - foreach e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - double { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is double -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type double. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - if {[tcl::dict::size $thisarg_checks]} { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -range { - #todo - small-value double comparisons with error-margin? review - #todo - empty string for low or high - lassign $checkval low high - if {$e_check < $low || $e_check > $high} { - set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - bool { - foreach e_check $vlist_check { - if {![tcl::string::is boolean -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - dict { - foreach e_check $vlist_check { - if {[llength $e_check] %2 != 0} { - set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[tcl::dict::size $e_check] < $checkval} { - set msg "$argclass '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::dict::size $e_check] > $checkval} { - set msg "$argclass '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - } - alnum - - alpha - - ascii - - control - - digit - - graph - - lower - - print - - punct - - space - - upper - - wordchar - - xdigit { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is $type -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - file - - directory - - existingfile - - existingdirectory { - foreach e $vlist e_check $vlist_check { - #//review - we may need '?' char on windows - if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { - #what about special file names e.g on windows NUL ? - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - if {$type eq "existingfile"} { - foreach e $vlist e_check $vlist_check { - if {![file exists $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } elseif {$type eq "existingdirectory"} { - foreach e $vlist e_check $vlist_check { - if {![file isdirectory $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } - } - char { - #review - char vs unicode codepoint vs grapheme? - foreach e $vlist e_check $vlist_check { - if {[tcl::string::length $e_check] != 1} { - set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } - } - - } - - if {$is_strip_ansi} { - set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach - if {[tcl::dict::get $thisarg -multiple]} { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict $argname $stripped_list - } - option { - tcl::dict::set opts $argname $stripped_list - } - value { - tcl::dict::set values_dict $argname $stripped_list - } - } - } else { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict [lindex $stripped_list 0] - } - option { - tcl::dict::set opts $argname [lindex $stripped_list 0] - } - value { - tcl::dict::set values_dict [lindex $stripped_list 0] - } - } - } - } - } - - #maintain order of opts $opts values $values as caller may use lassign. - set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] - if {[llength $receivednames]} { - #flat zip of names with overall posn, including opts - #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] - set i -1 - set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] - } else { - set received_posns [list] - } - #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) - #(e.g using 'dict exists $received -flag') - # - but it can have duplicate keys when args/opts have -multiple 1 - #It is actually a list of paired elements - return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived multis $multisreceived] - } - - - proc forms {id} { - set spec [get_spec $id] - if {[dict size $spec]} { - return [dict get $spec form_names] - } else { - return [list] - } - } - lappend PUNKARGS [list { - @id -id ::punk::args::synopsis - @cmd -name punk::args::synopsis -help\ - "Return synopsis for each form of a command id - on separate lines. - If -form is given, supply only - the synopsis for that form. - " - @opts - -form -type string -default * - -return -type string -default full -choices {full summary dict} - @values -min 1 -max -1 - cmditem -multiple 1 -optional 0 - }] - proc synopsis {args} { - set argd [punk::args::parse $args withid ::punk::args::synopsis] - - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - if {$has_punkansi} { - set I [punk::ansi::a+ italic] - set RST [punk::ansi::a] - } else { - set I "" - set RST "" - } - - ##set form * - ##if {[lindex $args 0] eq "-form"} { - ## set arglist [lrange $args 2 end] - ## set form [lindex $args 1] - ##} else { - ## set arglist $args - ##} - ##if {[llength $arglist] == 0} { - ## error "punk::args::synopsis expected command id possibly with trailing subcommands/args" - ##} - ##set id [lindex $arglist 0] - ##set cmdargs [lrange $arglist 1 end] - - lassign [dict values $argd] leaders opts values - set form [dict get $opts -form] - set opt_return [dict get $opts -return] - set cmditems [dict get $values cmditem] - set id [lindex $cmditems 0] - set cmdargs [lrange $cmditems 1 end] - - - set spec [get_spec $id] - if {$spec eq ""} { - return - } - set form_names [dict get $spec form_names] - if {$form ne "*"} { - if {[string is integer -strict $form]} { - set f [lindex $form_names $form] - if {$f ne ""} { - set form_names [list $f] - } else { - set form_names [list] - } - } else { - if {$form in $form_names} { - set form_names [list $form] - } else { - set form_names [list] - } - } - } - - set SYND [dict create] - set syn "" - #todo - -multiple etc - foreach f $form_names { - set SYNLIST [list] - dict set SYND $f [list] - append syn "$id" - set forminfo [dict get $spec FORMS $f] - foreach argname [dict get $forminfo LEADER_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set ARGD [dict create argname $argname class leader] - if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - set display [lindex [dict get $arginfo -choices] 0] - } elseif {[dict get $arginfo -type] eq "literal"} { - set display $argname - } else { - set display $I$argname$RST - } - if {[dict get $arginfo -optional]} { - append syn " ?$display?" - } else { - append syn " $display" - } - dict set ARGD type [dict get $arginfo -type] - dict set ARGD optional [dict get $arginfo -optional] - dict set ARGD display $display - dict lappend SYND $f $ARGD - } - foreach argname [dict get $forminfo OPT_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set ARGD [dict create argname $argname class option] - set tp [dict get $arginfo -type] - if {[dict get $arginfo -optional]} { - if {[dict get $arginfo -multiple]} { - if {$tp eq "none"} { - set display "?$argname?..." - } else { - set display "?$argname <$tp>?..." - } - } else { - if {$tp eq "none"} { - set display "?$argname?" - } else { - set display "?$argname <$tp>?" - } - } - } else { - if {[dict get $arginfo -multiple]} { - if {$tp eq "none"} { - set display "$argname ?$argname...?" - } else { - set display "$argname <$tp> ?$argname <$tp>?..." - } - } else { - if {$tp eq "none"} { - set display $argname - } else { - set display "$argname <$tp>" - } - } - } - append syn " $display" - dict set ARGD type [dict get $arginfo -type] - dict set ARGD optional [dict get $arginfo -optional] - dict set ARGD display $display - dict lappend SYND $f $ARGD - } - foreach argname [dict get $forminfo VAL_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set ARGD [dict create argname $argname class value] - if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} { - if {[dict get $arginfo -multiple]} { - set display "?$I$argname$RST?..." - } else { - if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - set display "?[lindex [dict get $arginfo -choices] 0]?" - } elseif {[dict get $arginfo -type] eq "literal"} { - set display "?$argname?" - } else { - set display "?$I$argname$RST?" - } - } - } else { - if {[dict get $arginfo -multiple]} { - set display "$I$argname$RST ?$I$argname$RST?..." - } else { - if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - set display "[lindex [dict get $arginfo -choices] 0]" - } elseif {[dict get $arginfo -type] eq "literal"} { - set display $argname - } else { - set display "$I$argname$RST" - } - } - } - append syn " $display" - dict set ARGD type [dict get $arginfo -type] - dict set ARGD optional [dict get $arginfo -optional] - dict set ARGD display $display - dict lappend SYND $f $ARGD - } - append syn \n - } - switch -- $opt_return { - full { - return [string trim $syn \n] - } - summary { - set summary "" - dict for {form arglist} $SYND { - append summary $id - set class_state leader - set option_count 0 - set value_count 0 - foreach ainfo $arglist { - switch -- [dict get $ainfo class] { - leader { - append summary " [dict get $ainfo display]" - } - option { - incr option_count - } - value { - incr value_count - if {$class_state ne "value"} { - if {$option_count > 0} { - append summary " ?options ($option_count defined)?" - } - set class_state value - } - append summary " [dict get $ainfo display]" - } - } - } - if {$value_count == 0 && $option_count > 0} { - append summary " ?options ($option_count defined)?" - } - append summary \n - } - set summary [string trim $summary \n] - return $summary - } - dict { - return $SYND - } - } - } - - - lappend PUNKARGS [list { - @id -id ::punk::args::synopsis_summary - @cmd -name punk::args::synopsis_summary -help\ - "Reduce the width of a synopsis string - by coalescing options to ?options?... - synopsis string may be arbitrarily marked - up with ANSI codes." - @opts - @values -min 1 -max -1 - synopsis -multiple 0 -optional 0 - }] - proc synopsis_summary {args} { - set argd [punk::args::parse $args withid ::punk::args::synopsis_summary] - set synopsis [dict get $argd values synopsis] - set summary "" - foreach sline [split $synopsis \n] { - set sline [regsub -all {\s+} $sline " "] ;#normalize to single spacing only - review - set in_opt 0 - set line_out "" - set codestack [list] - set parts [punk::ansi::ta::split_codes_single $sline] - #basic - foreach {pt code} $parts { - set charlist [split $pt ""] - for {set i 0} {$i < [llength $charlist]} {incr i} { - set c [lindex $charlist $i] - - switch -- $c { - ? { - if {!$in_opt} { - set in_opt 1 - } else { - - } - } - " " { - if {!$in_opt} { - append line_out " " - } else { - set in_opt - } - } - default { - if {!$in_opt} { - append line_out $c - } - } - } - } - if {$code ne ""} { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set codestack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set codestack [list $code] - } elseif {[punk::ansi::codetype::is_sgr $code]} { - #basic simplification first - remove straight dupes - set dup_posns [lsearch -all -exact $codestack $code] ;#must be -exact because of square-bracket glob chars - set codestack [lremove $codestack {*}$dup_posns] - lappend codestack $code - } else { - #? ignore other ANSI codes? - } - } - } - if {[string match -* $plain_s] || [string match ?- $plain_s]} { - } - } - return $summary - } - - lappend PUNKARGS [list { - @id -id ::punk::args::TEST - @opts -optional 0 - -o1 -default 111 -help "opt 1 mandatory" - @opts -optional 1 - -o2 -default 222 -help "opt 2 optional" - @values -min 0 -max 1 - v -help\ - "v1 optional" - }] - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::lib { - variable PUNKARGS - tcl::namespace::export * - tcl::namespace::path [list [tcl::namespace::parent]] - #*** !doctools - #[subsection {Namespace punk::args::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 flatzip {l1 l2} { - concat {*}[lmap a $l1 b $l2 {list $a $b}] - } - - if {[info commands lseq] ne ""} { - #tcl 8.7+ lseq significantly faster, especially for larger ranges - #The internal rep can be an 'arithseries' with no string representation - proc zero_based_posns {count} { - if {$count < 1} {return} - lseq 0 $count-1 - } - } else { - proc zero_based_posns {count} { - if {$count < 1} {return} - lsearch -all [lrepeat $count 0] * - } - } - - #return list of single column-width marks - possibly with ansi - proc choiceinfo_marks {choice choiceinfodict} { - set marks [list] - if {[dict exists $choiceinfodict $choice]} { - set cinfo [dict get $choiceinfodict $choice] - foreach info $cinfo { - if {[lindex $info 0] eq "doctype"} { - switch -- [lindex $info 1] { - punkargs { - lappend marks [punk::ns::Cmark punkargs brightgreen] - } - ensemble { - lappend marks [punk::ns::Cmark ensemble brightyellow] - } - oo { - lappend marks [punk::ns::Cmark oo brightcyan] - } - ooc { - lappend marks [punk::ns::Cmark ooc cyan] - } - ooo { - lappend marks [punk::ns::Cmark ooo cyan] - } - native { - lappend marks [punk::ns::Cmark native] - } - unknown { - lappend marks [punk::ns::Cmark unknown brightred] - } - } - } - } - } - return $marks - } - - - #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 -1] in calling scope ${[lindex [set x] 0]} !} - lappend PUNKARGS [list { - @id -id ::punk::args::lib::tstr - @cmd -name punk::args::lib::tstr -help\ - "A rough equivalent of js template literals - - Substitutions: - \$\{$varName\} - \$\{[myCommand]\} - (when -allowcommands flag is given)" - -allowcommands -default 0 -type none -help\ - "If -allowcommands is present, placeholder can contain commands - e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" - -undent -default 1 -type boolean -help\ - "undent/dedent the template lines. - The longest common prefix of whitespace is removed" - -indent -default "" -type string -help\ - "String with which to indent the template - prior to substitution. - If -undent is enabled, that is performed - first, then the indent is applied." - -paramindents -default line -choices {none line position} -choicelabels { - line\ - " Use leading whitespace in - the line in which the - placeholder occurs." - position\ - " Use the position in - the line in which the - placeholder occurs." - none\ - " No indents applied to - subsequent placeholder value - lines. This will usually - result in text awkwardly - ragged unless the source code - has also been aligned with the - left margin or the value has - been manually padded." - } -help\ - "How indenting is done for subsequent lines in a - multi-line placeholder substitution value. - The 1st line or a single line value is always - placed at the placeholder. - paramindents are performed after the main - template has been indented/undented. - (indenting by position does not calculate - unicode double-wide or grapheme cluster widths) - " - #choicelabels indented by 1 char is clearer for -return string - and reasonable in table - -return -default string -choices {dict list string args}\ - -choicelabels { - dict\ - " Return a dict with keys - 'template', 'params' and - 'errors'" - string\ - " Return a single result - being the string with - placeholders substituted." - list\ - " Return a 2 element list. - The first is itself a list - of plaintext portions of the - template, split at each point - at which placeholders were - present. The second element - of the outer list is a list - of placeholder values if -eval - is 1, or a list of the raw - placeholder strings if -eval - is 0." - args\ - " Return a list where the first - element is a list of template - plaintext sections as per the - 'list' return mechanism, but the - placeholder items are individual - items in the returned list. - This can be useful when passing - the expanded result of a tstr - command to another function - which expects the placeholders - as individual arguments" - } - -eval -default 1 -type boolean -help\ - "Whether to evaluate the \$\{\} placeholders. - When -return is string, -eval should generally be set to 1. - For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. - contained variables in that case should be braced or whitespace separated, or the variable - name is likely to collide with surrounding text. - e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" - @values -min 0 -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 - e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} - - Escape sequences such as \\n and unicode escapes are processed within placeholders. - " - }] - - proc tstr {args} { - #Too hard to fully eat-our-own-dogfood from within punk::args package - # - we use punk::args within the unhappy path only - #set argd [punk::args::get_by_id ::punk::lib::tstr $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 opt_eval [dict get $argd opts -eval] - - set templatestring [lindex $args end] - set arglist [lrange $args 0 end-1] - set opts [dict create\ - -allowcommands 0\ - -undent 1\ - -indent ""\ - -paramindents line\ - -eval 1\ - -return string\ - ] - if {"-allowcommands" in $arglist} { - set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] - dict set opts -allowcommands 1 - } - if {[llength $arglist] % 2 != 0} { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr expected option/value pairs prior to last argument" - } - } - dict for {k v} $arglist { - set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] - switch -- $fullk { - -indent - -undent - -paramindents - -return - -eval { - dict set opts $fullk $v - } - default { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" - } - } - } - } - set opt_allowcommands [dict get $opts -allowcommands] - set opt_paramindents [dict get $opts -paramindents] - set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] - if {$test_paramindents ni {none line position}} { - error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." - } - set opt_paramindents $test_paramindents - set opt_return [dict get $opts -return] - set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] - if {$opt_return eq ""} { - } - set opt_eval [dict get $opts -eval] - - - set nocommands "-nocommands" - if {$opt_allowcommands == 1} { - set nocommands "" - } - - set opt_undent [dict get $opts -undent] - if {$opt_undent} { - set templatestring [punk::args::lib::undent $templatestring] - } - set opt_indent [dict get $opts -indent] - if {$opt_indent ne ""} { - set templatestring [punk::args::lib::indent $templatestring $opt_indent] - } - - #set parts [_tstr_split $templatestring] - if {[string first \$\{ $templatestring] < 0} { - set parts [list $templatestring] - } else { - set parts [_parse_tstr_parts $templatestring] - } - set textchunks [list] - #set expressions [list] - set params [list] - set idx 0 - set errors [dict create] - set lastline "" ;#todo - first line has placeholder? - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach {pt expression} $parts { - lappend textchunks $pt - incr idx ;#pt incr - - #ignore last expression - if {$idx == [llength $parts]} { - break - } - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - #lappend expressions $expression - #---------------------- - #REVIEW - JMN - #TODO - debug punk::args loading of @dynamic defs - #puts "-- $expression" - #---------------------- - #brk1 - literal newline not {\n} - set leader "" - if {[set brk1 [string first \n $expression]] >= 0} { - #undent left of paramstart only for lines of expression that arent on opening ${..} line - set tail [string range $expression $brk1+1 end] - set leader [string repeat " " [string length $lastline]] - set undentedtail [punk::args::lib::undentleader $tail $leader] - #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] - set expression "[string range $expression 0 $brk1]$undentedtail" - } - if {$opt_eval} { - if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { - lappend params [string cat \$\{ $expression \}] - dict set errors [expr {[llength $params]-1}] $result - } else { - set result [string map [list \n "\n$leader"] $result] - lappend params $result - } - #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] - } else { - lappend params [subst -nocommands -novariables $expression] - } - append lastline [lindex $params end] ;#for current expression's position calc - - incr idx ;#expression incr - } - - if {$opt_return eq "dict"} { - return [dict create template $textchunks params $params errors $errors] - } - if {[dict size $errors]} { - set einfo "" - dict for {i e} $errors { - append einfo "parameter $i error: $e" \n - } - #REVIEW!!! - #TODO - fix - #puts stderr "tstr errors:\n$einfo\n" - } - - switch -- $opt_return { - list { - return [list $textchunks $params] - } - args { - #see example in tstr_test_one - return [list $textchunks {*}$params] - } - string { - #todo - flag to disable indent-matching behaviour for multiline param? - set out "" - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach pt $textchunks param $params { - if {$opt_paramindents eq "none"} { - append out $pt $param - } else { - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - if {$opt_paramindents eq "line"} { - regexp {(\s*).*} $lastline _all lastindent - } else { - #position - #TODO - detect if there are grapheme clusters - #This regsub doesn't properly space unicode double-wide chars or clusters - set lastindent "[regsub -all {\S} $lastline " "] " - } - if {$lastindent ne ""} { - set paramlines [split $param \n] - if {[llength $paramlines] == 1} { - append out $pt $param - } else { - append out $pt [lindex $paramlines 0] - foreach nextline [lrange $paramlines 1 end] { - append out \n $lastindent $nextline - } - } - } else { - append out $pt $param - } - append lastline $param - } - } - return $out - } - } - } - #test single placeholder tstr args where single placeholder must be an int - proc tstr_test_one {args} { - set argd [punk::args::parse $args withdef { - @cmd -name ::punk::args::lib::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 -return args {Select * from table where id = \$\{$id\} and etc... ;}] - } - - @values -min 2 -max 2 - template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - - but the tstr call in the example 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} - }] - 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]] ""] - set result [string cat [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 dollar sign - 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]] - } - - #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. - proc indent {text {prefix " "}} { - set result [list] - foreach line [split $text \n] { - if {[string trim $line] eq ""} { - lappend result "" - } else { - lappend result $prefix[string trimright $line] - } - } - return [join $result \n] - } - #dedent? - proc undent {text} { - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - regexp {^([\t ]*)} $lcp _m lcp - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - - #hacky - proc undentleader {text leader} { - #leader usually whitespace - but doesn't have to be - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - lappend nonblank "${leader}!!" - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - #regexp {^([\t ]*)} $lcp _m lcp - #lcp can be shorter than leader - set lcp [string range $lcp 0 [string length $leader]-1] - - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - #A version of textutil::string::longestCommonPrefixList - proc longestCommonPrefix {items} { - if {[llength $items] <= 1} { - return [lindex $items 0] - } - set items [lsort $items[unset items]] - set min [lindex $items 0] - set max [lindex $items end] - #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) - #(sort order nothing to do with length - e.g min may be longer than max) - if {[string length $min] > [string length $max]} { - set temp $min - set min $max - set max $temp - } - set n [string length $min] - set prefix "" - set i -1 - while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { - append prefix $c - } - return $prefix - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] -} - -tcl::namespace::eval punk::args::argdocbase { - namespace export * - #use a? to test and create literal ansi here rather than relying on punk::ansi package presence - #e.g - #% a? bold - #- bold │SGR 1│sample│␛[1msample - #- ──────┼─────┼──────┼────────── - #- RESULT│ │sample│␛[1msample - proc B {} {return \x1b\[1m} ;#a+ bold - proc N {} {return \x1b\[22m} ;#a+ normal - proc I {} {return \x1b\[3m} ;#a+ italic - proc NI {} {return \x1b\[23m} ;#a+ noitalic - -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::package { - variable PUNKARGS - lappend PUNKARGS [list { - @dynamic - @id -id "::punk::args::package::standard_about" - @cmd -name "%pkg%::about" -help\ - "About %pkg% - ... - " - -package_about_namespace -type string -optional 0 -help\ - "Namespace containing the package about procedures - Must contain " - -return\ - -type string\ - -default table\ - -choices {string table tableobject}\ - -choicelabels { - string\ - "A basic text layout" - table\ - "layout in table borders - (requires package: textblock)" - tableobject\ - "textblock::class::table object instance" - }\ - -help\ - "Choose the return type of the 'about' information" - topic -optional 1\ - -nocase 1\ - -default {*}\ - -choices {Description License Version Contact *}\ - -choicerestricted 0\ - -choicelabels { - - }\ - -multiple 1\ - -help\ - "Topic to display. Omit or specify as * to see all. - If * is included with explicit topics, * represents - the remaining unmentioned topics." - }] - proc standard_about {args} { - set argd [punk::args::parse $args withid ::punk::args::package::standard_about] - lassign [dict values $argd] leaders OPTS values received - - set pkgns [dict get $OPTS -package_about_namespace] - if {[info commands ${pkgns}::package_name] eq ""} { - error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" - } - set pkgname [${pkgns}::package_name] - - set opt_return [dict get $OPTS -return] - set all_topics [${pkgns}::about_topics] - if {![dict exists $received topic]} { - set topics $all_topics - } else { - # * represents all remaining topics not explicitly mentioned. - set val_topics [dict get $values topic] ;#if -multiple is true, this is a list - set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] - set topics [list] - foreach t $val_topics { - if {$t eq "*"} { - foreach a $all_topics { - if {$a ni $explicit_topics} { - lappend topics $a - } - } - } else { - lappend topics $t - } - } - } - if {$opt_return ne "string"} { - package require textblock ;#table support - set is_table 1 - set title [string cat {[} $pkgname {]} ] - set t [textblock::class::table new -title $title] - $t configure -frametype double -minwidth [expr {[string length $title]+2}] - - } else { - set topiclens [lmap t $topics {string length $t}] - set widest_topic [tcl::mathfunc::max {*}$topiclens] - set is_table 0 - set about "$pkgname\n" - append about [string repeat - $widest_topic] \n - } - foreach topic $topics { - if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { - set topic_contents [::${pkgns}::get_topic_$topic] - } else { - set topic_contents "" - } - if {!$is_table} { - set content_lines [split $topic_contents \n] - append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n - foreach ln [lrange $content_lines 1 end] { - append about [format %-${widest_topic}s ""] " " $ln \n - } - } else { - $t add_row [list $topic $topic_contents] - } - } - - if {!$is_table} { - return $about - } else { - if {$opt_return eq "tableobject"} { - return $t - } - set result [$t print] - $t destroy - return $result - } - } - -} - -#usually we would directly call arg definitions near the defining proc, -# so that the proc could directly use the definition in its parsing. -# -#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. -#arguably it may be more processor-cache-efficient to do together like this anyway. - -#can't do this here? - as there is circular dependency with punk::lib -#tcl::namespace::eval punk::args { -# foreach deflist $PUNKARGS { -# punk::args::define {*}$deflist -# } -# set PUNKARGS "" -#} - -lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -tcl::namespace::eval punk::args::system { - #*** !doctools - #[subsection {Namespace punk::args::system}] - #[para] Internal functions that are not part of the API - - #dict get value with default wrapper for tcl 8.6 - if {[info commands ::tcl::dict::getdef] eq ""} { - proc Dict_getdef {dictValue args} { - set keys [lrange $args 0 end-1] - if {[tcl::dict::exists $dictValue {*}$keys]} { - return [tcl::dict::get $dictValue {*}$keys] - } else { - return [lindex $args end] - } - } - } else { - #we pay a minor perf penalty for the wrap - interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef - } - - #name to reflect maintenance - home is punk::lib::ldiff - proc punklib_ldiff {fromlist removeitems} { - if {[llength $removeitems] == 0} {return $fromlist} - set result {} - foreach item $fromlist { - if {$item ni $removeitems} { - lappend result $item - } - } - return $result - } - -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::args [tcl::namespace::eval punk::args { - tcl::namespace::path {::punk::args::lib ::punk::args::system} - variable pkg punk::args - variable version - set version 0.1.7 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.8.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.8.tm deleted file mode 100644 index c17ecc2c..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.8.tm +++ /dev/null @@ -1,7213 +0,0 @@ -# -*- 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: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.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 punk::args 0.1.8 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.1.8] -#[copyright "2024"] -#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] -#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] -#[require punk::args] -#[keywords module proc args arguments parse] -#[description] -#[para]Utilities for parsing proc args - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). -#[para] overview of punk::args -#[subsection Concepts] -#[para]There are 2 main conventions for parsing a proc args list -#[list_begin enumerated] -#[enum] -#[para]leading option-value pairs and flags followed by a list of values (Tcl style) -#[enum] -#[para]leading list of values followed by option-value pairs and flags (Tk style) -#[list_end] -#[para]There are exceptions in both Tcl and Tk commands regarding this ordering -#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style -#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] -#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. -#[para] -#[para]The basic principle is that a call to punk::args::parse is made near the beginning of the proc with a cacheable argument defining the parameters e.g -#[example { -# proc dofilestuff {args} { -# lassign [dict values [punk::args::parse $args withdef { -# @cmd -help "do some stuff with files e.g dofilestuff " -# @opts -type string -# #comment lines ok -# -directory -default "" -# -translation -default binary -# #setting -type none indicates a flag that doesn't take a value (solo flag) -# -nocomplain -type none -# @values -min 1 -max -1 -# }]] leaders opts values -# -# puts "translation is [dict get $opts -translation]" -# foreach f [dict values $values] { -# puts "doing stuff with file: $f" -# } -# } -#}] -#[para]The lines beginning with @ are usually optional in most cases and can be used to set defaults and some extra controls -#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values -#[para]valid @ lines being with @cmd @leaders @opts @values -#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. -#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. -#[para]e.g the result from the punk::args::parse call above may be something like: -#[para] leaders {} opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} -#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments -#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments -#[para]This could also be implemented entirely using args - and the @leaders category of arguments -#[example { -# proc dofilestuff {category args} { -# lassign [dict values [punk::args::parse $args withdef { -# @id -id ::dofilestuff -# -directory -default "" -# -translation -default binary -# -nocomplain -type none -# @values -min 2 -max 2 -# fileA -type existingfile 1 -# fileB -type existingfile 1 -# }]] leaders opts values -# puts "$category fileA: [dict get $values fileA]" -# puts "$category fileB: [dict get $values fileB]" -# } -#}] -#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 -#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored -#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, -#[para] or an additional call could be made to punk::args e.g -#[example { -# punk::args::parse [list $category $another_leading_arg] withdef { -# category -choices {cat1 cat2 cat3} -# another_leading_arg -type boolean -# } -#}] - -#*** !doctools -#[subsection Notes] -#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. -#[para] -#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. -#For functions that are part of an API a package may be more suitable. -#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) -#[example { -# proc test_switch {args} { -# set opts [dict create\\ -# -return "object"\\ -# -frametype "heavy"\\ -# -show_edge 1\\ -# -show_seps 0\\ -# -x a\\ -# -y b\\ -# -z c\\ -# -1 1\\ -# -2 2\\ -# -3 3\\ -# ] -# foreach {k v} $args { -# switch -- $k { -# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { -# dict set opts $k $v -# } -# default { -# error "unrecognised option '$k'. Known options [dict keys $opts]" -# } -# } -# } -# return $opts -# } -#}] -#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. -#[para] -# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. -# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. -#[para]use punk::lib::show_jump_tables to verify that a jump table exists. -#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous -#[example { -# proc test_prefix {args} { -# set opts [dict create\ -# -return string\ -# -frametype \uFFEF\ -# -show_edge \uFFEF\ -# -show_seps \uFFEF\ -# -x a\ -# -y b\ -# -z c\ -# -1 1\ -# -2 2\ -# -3 3\ -# ] -# if {[llength $args]} { -# set knownflags [dict keys $opts] -# } -# foreach {k v} $args { -# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v -# } -# return $opts -# } -#}] -#[para]There are many alternative args parsing packages a few of which are listed here. -#[list_begin enumerated] -#[enum]argp (pure tcl) -#[enum]parse_args (c implementation) -#[enum]argparse (pure tcl *) -#[enum]cmdline (pure tcl) -#[enum]opt (pure tcl) distributed with Tcl but considered deprecated -#[enum]The tcllib set of TEPAM modules (pure tcl) -#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. -#[list_end] -#[para] (* c implementation planned/proposed) -#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. -#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences -#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. -#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. -#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. -#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. -#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -#All ensemble commands are slower in a safe interp as they aren't compiled the same way -#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 -#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. -#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) -#ensembles: array binary clock dict info namespace string -#possibly file too, although that is generally hidden/modified in a safe interp -#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc -#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::args -#[list_begin itemized] -package require Tcl 8.6- -#optional? punk::trie -#optional? punk::textblock -#*** !doctools -#[item] [package {Tcl 8.6-}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -tcl::namespace::eval punk::args::register { - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] cooperative namespace punk::args::register - #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded - #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. - #[list_begin definitions] - - #Although the actual punk::args::define calls are not too sluggish, there could be *many*. - #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, - #especially since a fair proportion may be for documentation purposes rather than parsing args. - - # -- --- --- --- --- --- --- --- - #cooperative with packages that define some punk args but do so lazily - #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first - variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective - if {![info exists ::punk::args::register::NAMESPACES]} { - set ::punk::args::register::NAMESPACES [list] - } - # -- --- --- --- --- --- --- --- - - variable loaded_packages - if {![info exists loaded_packages]} { - set loaded_packages [list] ;#fully loaded - } - variable loaded_info - if {![info exists loaded_info]} { - set loaded_info [dict create] ;#time - } - variable scanned_packages - if {![info exists scanned_packages]} { - set scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages - } - variable scanned_info ;#time and idcount - if {![info exists scanned_info]} { - set scanned_info [dict create] - } - #some packages, e.g punk::args::tclcore document other namespaces. - #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources - variable namespace_docpackages - if {![info exists namespace_docpackages]} { - set namespace_docpackages [dict create] - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::register ---}] -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args { - - - variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. - - tcl::namespace::export {[a-z]*} - variable rawdef_cache - if {![info exists rawdef_cache]} { - set rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} - } - variable id_cache_rawdef - if {![info exists id_cache_rawdef]} { - set id_cache_rawdef [tcl::dict::create] - } - variable id_cache_spec - if {![info exists id_cache_spec]} { - set id_cache_spec [tcl::dict::create] - } - - variable argdefcache_unresolved - if {![info exists argdefcache_unresolved]} { - set argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) - } - - variable argdata_cache - if {![info exists argdata_cache]} { - set argdata_cache [tcl::dict::create] - } - - variable id_counter - if {![info exists id_counter]} { - set id_counter 0 - } - - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] Core API functions for punk::args - #[list_begin definitions] - - #todo - some sort of punk::args::cherrypick operation to get spec from an existing set - #todo - doctools output from definition - - - - - #todo? -synonym/alias ? (applies to opts only not values) - #e.g -background -aliases {-bg} -default White - #review - how to make work with trie prefix - #e.g - # -corner -aliases {-corners} - # -centre -aliases {-center -middle} - #We mightn't want the prefix to be longer just because of an alias - #we should get -co -ce and -m from the above as abbreviations - - set map [list %G% \x1b\[32m %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] - - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::define - #todo @preamble -help "move large block outside of table?" - @cmd -name punk::args::define -help\ - "Accepts a line-based definition of command arguments. - The definition can be supplied as a single text block or multiple as described - in the help information for 'text' below. - - Returns an id which is a key to the stored definition. - The id is taken from the supplied definition's @id -id line, or is an - automatically created id of the form 'autoid_'. - - At the time define is called - just the raw text arguments are stored for the id. - When the id is first used, for example with 'punk::args::parse $args withid $id', - the raw definition is parsed into a stored specifications dictionary. - - This specifications dictionary is structured for (optional) use within commands to - parse and validate the arguments - and is also used when retrieving definitions - (or parts thereof) for re-use. - - This can be used purely for documentation or called within a function to parse a mix - of leading values, switches/flags and trailing values. - - The overhead is favourably comparable with other argument processors - but none are - as fast as minimal code with a switch statement. For toplevel commands where a few - 10s of microseconds is immaterial, the validation and automated error formatting in - a table can be well worthwhile. For inner procs requiring utmost speed, the call can - be made only on the unhappy path when basic processing determines a mismatch - or it - can be left entirely as documentation for interactive use with: i ... - and for synopsis generation with: s ... - - The definition should usually contain an initial line of the form: @id -id ::somecmd - - Blank lines are ignored at the top level, ie if they are not part of another structure. - Similarly - lines at the top level beginning with the # character are ignored. - All other toplevel lines must consist of a leading word followed by paired arguments. - The arguments can be spread over multiple lines and contain lines of near-arbitrary - text if they are properly braced or double quoted and Tcl escaping for inner quotes - or unbalanced braces is maintained. - The line continuation character - (\\ at the end of the line) can be used to continue the set of arguments for - a leading word. - Leading words beginning with the @ character are directives controlling argument - parsing, defaults for subsequent arguments, and help display. - directives include: - %B%@id%N% ?opt val...? - directive-options: -id - %B%@cmd%N% ?opt val...? - directive-options: -name -help - %B%@leaders%N% ?opt val...? - (used for leading args that come before switches/opts) - directive-options: -min -max -unnamed - (also accepts options as defaults for subsequent arguments) - %B%@opts%N% ?opt val...? - directive-options: -any|-arbitrary - %B%@values%N% ?opt val...? - (used for trailing args that come after switches/opts) - directive-options: -min -max -unnamed - (also accepts options as defaults for subsequent arguments) - %B%@form%N% ?opt val...? - (used for commands with multiple forms) - directive-options: -form -synopsis - The -synopsis value allows overriding the auto-calculated - synopsis. - %B%@formdisplay%N% ?opt val...? - directive-options: -header (text for header row of table) - -body (override autogenerated arg info for form) - %B%@doc%N% ?opt val...? - directive-options: -name -url - %B%@seealso%N% ?opt val...? - directive-options: -name -url (for footer - unimplemented) - - Some other options normally present on custom arguments are available - to use with the @leaders @opts @values directives to set defaults - for subsequent lines that represent your custom arguments. - These 3 directives should occur in exactly this order - but can be - repeated with custom argument lines interspersed. - - An @id line can only appear once and should be the first item. - For the commandline usage to be displayed either on parsing error - or using the i .. function - an @id with -id is needed. - - All directives can be omitted, in which case every line represents - a custom leader, value or option. - All will be leaders by default if no options defined. - If options are defined (by naming with leading dash, or explicitly - specifying @opts) then the definitions prior to the options will be - categorised as leaders, and those following the options will be - categorised as values. - - Custom arguments are defined by using any word at the start of a - line that doesn't begin with @ or - - (except that adding an additionl @ escapes this restriction so - that @@somearg becomes an argument named @somearg) - - custom leading args, switches/options (names starting with -) - and trailing values also take spec-options: - - -type - defaults to string. If no other restrictions - are specified, choosing string does the least validation. - recognised types: - int|integer - number - list - indexexpression - dict - double - bool|boolean - char - file - directory - ansistring - globstring - (any of the types accepted by 'string is') - - The above all perform some validation checks - - string - (also any of the 'string is' types such as - xdigit, graph, punct, lower etc) - any - none - (used for switches only. Indicates this is - a 'solo' flag ie accepts no value) - - and more.. (todo - document here) - - -optional - (defaults to true for flags/switches false otherwise) - For non flag/switch arguments - all arguments with - -optional true must sit consecutively within their group. - ie all optional leader arguments must be together, and all - optional value arguments must be together. Furthermore, - specifying both optional leaders and optional values will - often lead to ambiguous parsing results. Currently, all - optional non-flg/switch arguments should be either at the - trailing end of leaders or the trailing end of values. - Further unambiguous arrangements of optional args may be - made in future - but are currently considered 'unsupported' - -default - -multiple (for leaders & values defines whether - subsequent received values are stored against the same - argument name - only applies to final leader OR final value) - (for options/flags this allows the opt-val pair or solo - flag to appear multiple times - not necessarily contiguously) - -choices {} - A list of allowable values for an argument. - The -default value doesn't have to be in the list. - If a -type is specified - it doesn't apply to choice members. - It will only be used for validation if the -choicerestricted - option is set to false. If all choices are specified in values - within the -choicegroups dict, it is not necessary to specify them - in the -choices list. It is effectively a simpler form of - specifying choices when no grouping is required. It is fine to - use both -choices and -choicegroups e.g specifying all in -choices - and then including only some that need grouping in -choicegroups. - -choicelabels {} - keys are the values/argument names from -choices (or equivalently - members of value entries from the -choicegroups dict) - The values in the choicelabels dict are text values, possibly - containing newlines, that are displayed below each choice. - This is commonly a very basic summary of the choice. In the - case of a subcommand it may be a usage synopsis for further - arguments. - -choicerestricted - Whether values not specified in -choices or -choicegroups are - allowed. Defaults to true. - -choiceprefix - This specifies whether unique prefixes are able to be used - instead of the complete string. This is calculated using - tcl::prefix::match - and will display in the autogenerated - usage output. Defaults to true. - -choiceprefixdenylist {} - These choices should match exactly a choice entry in one of - the settings -choices or -choicegroups. - These will still be used in prefix calculation - but the full - choice argument must be entered to select the choice. - -choiceprefixreservelist {} - These choices are additional values used in prefix calculation. - The values will not be added to the list of available choices. - -choicegroups {} - Generally this would be used instead of -choices to allow - usage display of choices grouped by some name (or the empty - string for 'ungrouped' items which appear first). - See for example the output if 'i zlib' where choices of the - next subcommand are grouped by the names compression,channel, - streaming and checksumming. The -choices list is equivalent - to a -choicegroups dict entry where the key (groupname) is - the empty string. Both may be specified, in which case the - final list of available choices will be a union of the listed - values in -choices and the values from each choice group. - Choice values specified in -choices are effectively ungrouped - unless overridden by placing them in a choicegroup. - -choicemultiple (default {1 1}) - is a pair representing min and max number of choices - that can be present in the value. - If is a single integer it is equivalent to a - specified with the same integer for both min and max. - Max of -1 represents no upper limit. - If allows more than one choice the value is a list - consisting of items in the choices made available through - entries in -choices/-choicegroups. - -minsize (type dependant) - -maxsize (type dependant) - -range (type dependant) - - - " - -dynamic -type boolean -default 0 -help\ - "If -dynamic is true, tstr interpolations of the form \$\{\$var\} - are re-evaluated on each call. - If the definition is being used not just as documentation, but is also - used within the function to parse args, e.g using punk::args::get_by_id, - then it should be noted that there is a slight performance penalty for the - dynamic case. - It is often not significant, perhaps depending on what vars/commands are - used but -dynamic true might be less desirable if the command is used in - inner loops in more performance-sensitive code. - " - @values -min 1 -max -1 - text -type string -multiple 1 -help\ - {Block(s) of text representing the argument definition for a command. - At least one must be supplied. If multiple, they are joined together with \n. - Using multiple text arguments may be useful to mix curly-braced and double-quoted - strings to have finer control over interpolation when defining arguments. - (this can also be handy for sections that pull resolved definition lines - from existing definitions (by id) for re-use of argument specifications and help text) - - e.g the following definition passes 2 blocks as text arguments - ${[punk::args::tclcore::argdoc::example { - punk::args::define { - @id -id ::myns::myfunc - @cmd -name myns::myfunc -help\ - "Description of command" - - %G%#The following option defines an option-value pair%R% - %G%#It may have aliases by separating them with a pipe |%R% - -fg|-foreground -default blah -type string -help\ - "In the result dict returned by punk::args::parse - the value used in the opts key will always be the last - entry, in this case -foreground" - %G%#The following option defines a flag style option (solo)%R% - -flag1 -default 0 -type none -help\ - "Info about flag1 - subsequent help lines auto-dedented by whitespace to left - of corresponding record start (in this case -flag1) - + first 4 spaces if they are all present. - This line has no extra indent relative to first line 'Info about flag1' - This line indented a further 6 chars" - - @values -min 1 -max -1 - %G%#Items that don't begin with * or - are value definitions%R% - v1 -type integer -default 0 - thinglist -type string -multiple 1 - } "@doc -name Manpage: -url [myfunc_manpage_geturl myns::myfunc]"}]} - } - }]] - - proc New_command_form {name} { - #probably faster to inline a literal dict create in the proc than to use a namespace variable - set leaderspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - -ensembleparameter 0\ - ] - set optspec_defaults [tcl::dict::create\ - -type string\ - -optional 1\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - -prefix 1\ - ] - set valspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - - #form record can have running entries such as 'argspace' that aren't given to arg parser - #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict - return [dict create\ - argspace "leaders"\ - ARG_INFO [tcl::dict::create]\ - ARG_CHECKS [tcl::dict::create]\ - LEADER_DEFAULTS [tcl::dict::create]\ - LEADER_REQUIRED [list]\ - LEADER_NAMES [list]\ - LEADER_MIN ""\ - LEADER_MAX ""\ - LEADER_UNNAMED false\ - LEADERSPEC_DEFAULTS $leaderspec_defaults\ - LEADER_CHECKS_DEFAULTS {}\ - OPT_DEFAULTS [tcl::dict::create]\ - OPT_REQUIRED [list]\ - OPT_NAMES [list]\ - OPT_ANY 0\ - OPT_MIN ""\ - OPT_MAX ""\ - OPT_SOLOS {}\ - OPTSPEC_DEFAULTS $optspec_defaults\ - OPT_CHECKS_DEFAULTS {}\ - VAL_DEFAULTS [tcl::dict::create]\ - VAL_REQUIRED [list]\ - VAL_NAMES [list]\ - VAL_MIN ""\ - VAL_MAX ""\ - VAL_UNNAMED false\ - VALSPEC_DEFAULTS $valspec_defaults\ - VAL_CHECKS_DEFAULTS {}\ - FORMDISPLAY [tcl::dict::create]\ - ] - - } - - proc errorstyle {args} { - #set or query the running config -errorstyle - #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? - #values: - #debug, enhanced, standard, basic, minimal - error todo - } - proc define {args} { - variable rawdef_cache - variable id_cache_rawdef - variable argdata_cache - if {[dict exists $rawdef_cache $args]} { - return [dict get [dict get $rawdef_cache $args] -id] - } else { - set id [rawdef_id $args] - if {[id_exists $id]} { - #we seem to be re-creating a previously defined id... - #clear any existing caches for this id - puts stderr "punk::args::define Redefinition of id:$id - clearing existing data" - - #dict unset argdata_cache $prevraw ;#silently does nothing if key not present - dict for {k v} $argdata_cache { - if {[dict get $v id] eq $id} { - dict unset argdata_cache $k - } - } - dict for {k v} $rawdef_cache { - if {[dict get $v -id] eq $id} { - dict unset rawdef_cache $k - } - } - dict unset id_cache_rawdef $id - } - set is_dynamic [rawdef_is_dynamic $args] - set defspace [uplevel 1 {::namespace current}] - dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic -defspace $defspace] - dict set id_cache_rawdef $id $args - return $id - } - } - - proc idquery_info {id} { - variable id_cache_rawdef - variable rawdef_cache - if {[dict exists $id_cache_rawdef $id]} { - set sep [string repeat - 40] - set rawdef [dict get $id_cache_rawdef $id] - if {[dict exists $rawdef_cache $rawdef]} { - set idinfo [dict get $rawdef_cache $rawdef] - } else { - set idinfo "" - } - set result "raw definition:" - append result \n $sep - append result \n $rawdef - append result \n $sep - append result \n "id info:" - append result \n $idinfo - append result \n $sep - variable argdata_cache - #lsearch -stride not avail (or buggy) in some 8.6 interps - search manually for now (2025). todo - modernize some time after Tcl 9.0/9.1 more widespread.(2027?) - #check for and report if id is present multiple times - set argdata_records [list] - dict for {k v} $argdata_cache { - if {[dict get $v id] eq $id} { - if {$k eq $rawdef} { - lappend argdata_records [list 1 $k $v] - } else { - lappend argdata_records [list 0 $k $v] - } - } - } - append result \n "argdata cache:" - if {![llength $argdata_records]} { - append result \n "(not present)" - } else { - append result \n "present [llength $argdata_records] time(s)" - foreach r $argdata_records { - lassign $r match k v - if {$match} { - append result \n " - present with same rawdef key" - } else { - append result \n " - present with different rawdef key" - append result \n " [punk::lib::indent $k { }]" - } - } - if {[llength $argdata_records] > 1} { - append result \n "*more than one record was not expected - review*" - } - } - append result \n $sep - return $result - } - } - - proc define2 {args} { - dict get [resolve {*}$args] id - } - - proc resolve {args} { - variable rawdef_cache - variable id_cache_rawdef - set defspace "" - if {[dict exists $rawdef_cache $args]} { - set cinfo [dict get $rawdef_cache $args] - set id [dict get $cinfo -id] - set is_dynamic [dict get $cinfo -dynamic] - if {[dict exists $cinfo -defspace]} { - set defspace [dict get $cinfo -defspace] - } - } else { - #should we really be resolving something that hasn't been defined? - set id [rawdef_id $args] - puts stderr "Warning: punk::args::resolve called with undefined id:$id" - set is_dynamic [rawdef_is_dynamic $args] - dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] - dict set id_cache_rawdef $id $args - } - - - variable argdata_cache - variable argdefcache_unresolved - - - set cache_key $args - #ideally we would use a fast hash algorithm to produce a short key with low collision probability. - #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) - #review - check if there is a built-into-tcl way to do this quickly - #for now we will just key using the whole string - #performance seems ok - memory usage probably not ideal - #quote from DKF 2021 - #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. - #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. - #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. - #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). - #> If dealing with very large amounts of data, using a database is probably a good plan. - - set textargs $args - if {![llength $args]} { - punk::args::get_by_id ::punk::args::define {} - return - } - #if {[lindex $args 0] eq "-dynamic"} { - # set is_dynamic [lindex $args 1] - # set textargs [lrange $args 2 end] - #} - - #experimental - set LVL 2 - - if {!$is_dynamic} { - if {[tcl::dict::exists $argdata_cache $cache_key]} { - return [tcl::dict::get $argdata_cache $cache_key] - } - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - if {[string first \$\{ $optionspecs] > 0} { - if {$defspace ne ""} { - #normal/desired case - #set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -paramindents none -allowcommands $optionspecs]] - } else { - #todo - deprecate/stop from happening? - puts stderr "punk::args::resolve calling tstr for id:$id with no known definition space (-defspace empty)" - set optionspecs [uplevel $LVL [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } - } - } else { - - if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { - set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel $LVL [list ::subst $param]] - } - } else { - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - #dynamic - double substitution required. - #e.g - # set DYN_CHOICES {${[::somewhere::get_choice_list]}} - # set RED [punk::ansi::a+ bold red] - # set RST [punk::ansi::a] - # punk::args::define { - # -arg -choices {${$DYN_CHOICES}} -help "${$RED}important info${$RST}" - #} - if {$defspace ne ""} { - set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } - #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) - if {[string first \$\{ $optionspecs] > 0} { - set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel $LVL [list ::subst $param]] - } - tcl::dict::set argdefcache_unresolved $cache_key $pt_params - } - } - #argdata_cache should be limited in some fashion or will be a big memory leak??? - if {[tcl::dict::exists $argdata_cache [list $optionspecs]]} { - #resolved cache version exists - return [tcl::dict::get $argdata_cache [list $optionspecs]] - } - } - - - - #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices - #default to 1 for convenience - - #checks with no default - #-minsize -maxsize -range - - - #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi - #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist - - #set opt_defaults [tcl::dict::create] - #set val_defaults [tcl::dict::create] - - #set opt_solos [list] - #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end - - set records [list] - set linebuild "" - - set linelist [split $optionspecs \n] - set lastindent "" - foreach ln $linelist { - if {[tcl::string::trim $ln] eq ""} {continue} - regexp {(\s*).*} $ln _all lastindent - break ;#break at first non-empty - } - #puts "indent1:[ansistring VIEW $lastindent]" - set in_record 0 - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - foreach rawline $linelist { - set recordsofar [tcl::string::cat $linebuild $rawline] - #ansi colours can stop info complete from working (contain square brackets) - #review - when exactly are ansi codes allowed/expected in record lines. - # - we might reasonably expect them in default values or choices or help strings - # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. - # - eg set line "set x \"a[a+ red]red[a]\"" - # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket - if {$has_punkansi} { - set test_complete [punk::ansi::ansistrip $recordsofar] - } else { - #review - #we only need to strip enough to stop interference with 'info complete' - set test_complete [string map [list \x1b\[ ""] $recordsofar] - } - if {![tcl::info::complete $test_complete]} { - #append linebuild [string trimleft $rawline] \n - if {$in_record} { - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. - #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. - #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. - #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) - #(note string first "" $str is fast and returns -1) - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline \n - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline \n - } else { - append linebuild $rawline \n - } - } else { - set in_record 1 - regexp {(\s*).*} $rawline _all lastindent - #puts "indent: [ansistring VIEW -lf 1 $lastindent]" - #puts "indent from rawline:$rawline " - append linebuild $rawline \n - } - } else { - set in_record 0 - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline - } else { - append linebuild $rawline - } - lappend records $linebuild - set linebuild "" - } - } - set cmd_info {} - set package_info {} - set id_info {} ;#e.g -children ?? - set doc_info {} - #set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table - set seealso_info {} - set keywords_info {} - ###set leader_min 0 - ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit - #set leader_max "" - #(common case of no leaders specified) - #set opt_any 0 - #set val_min 0 - #set val_max -1 ;#-1 for no limit - set DEF_definition_id $id - - #form_defs - set F [dict create _default [New_command_form _default]] - set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under - - #set ARGSPACE [dict create] ;#keyed on form - #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values - - set refs [dict create] - set record_type "" - set record_number -1 ;# - foreach rec $records { - set trimrec [tcl::string::trim $rec] - switch -- [tcl::string::index $trimrec 0] { - "" - # {continue} - } - incr record_number - set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict - if {[llength $record_values] % 2 != 0} { - #todo - avoid raising an error - store invalid defs keyed on id - error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" - } - # ---------------------------------------------------------- - # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. - #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! - #(form_ids_active is otherwise set in the @form handling block) - - #consider the following 2 line entry which is potentially dynamically included via a tstr: - # @form -form {* newform} - # @form -form {newform} -synopsis "cmd help ?stuff?" - #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. - #(because _default is usually 'taken over' by the first encountered form id) - #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record - #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. - - if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { - set patterns [dict get $record_values -form] - set record_form_ids [list] - foreach p $patterns { - if {[regexp {[*?\[\]]} $p]} { - #isglob - only used for matching existing forms - lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] - } else { - #don't test for existence - will define new form if necessary - lappend record_form_ids $p - } - } - #-form values could be globs that didn't match. record_form_ids could be empty.. - if {[llength $record_form_ids]} { - #only rename _default if it's the sole entry - if {[dict size $F] == 1 && [dict exists $F "_default"]} { - if {"_default" ni $record_form_ids} { - #only initial form exists - but we are mentioning new ones - #first rename the _default to first encountered new form id - #(just replace whole dict with new key - same data) - set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] - #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F - #we are only setting active because of the rename - @form is the way to change active forms list - set form_ids_active [lindex $record_form_ids 0] - } - } - foreach fid $record_form_ids { - if {![dict exists $F $fid]} { - if {$firstword eq "@form"} { - #only @form directly supplies keys - dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] - } else { - dict set F $fid [New_command_form $fid] - } - } else { - #update form with current record opts, except -form - if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } - } - } - } - } else { - #missing or empty -form - set record_form_ids $form_ids_active - if {$firstword eq "@form"} { - foreach fid $form_ids_active { - dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] - } - } - } - # ---------------------------------------------------------- - - set firstchar [tcl::string::index $firstword 0] - set secondchar [tcl::string::index $firstword 1] - if {$firstchar eq "@" && $secondchar ne "@"} { - set record_type "directive" - set directive_name $firstword - set at_specs $record_values - - switch -- [tcl::string::range $directive_name 1 end] { - dynamic { - set is_dynamic 1 - } - id { - #disallow duplicate @id line ? - #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) - - #id An id will be allocated if no id line present or the -id value is "auto" - - if {[dict exists $at_specs -id]} { - set thisid [dict get $at_specs -id] - if {$thisid ni [list $id auto]} { - error "punk::args::define @id mismatch existing: $id vs $thisid" - } - } - set id_info $at_specs - } - ref { - #a reference within the definition - #e.g see punk::args::tclcore ::after - #global reference dict - independent of forms - #ignore refs without an -id - #store all keys except -id - #complete overwrite if refid repeated later on - if {[dict exists $at_specs -id]} { - dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] - } - } - default { - #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple - #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) - #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) - #That is possibly too complicated and/or unnecessary? - #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? - - if {[dict exists $at_specs -id]} { - set copyfrom [get_spec [dict get $at_specs -id]] - #we don't copy the @id info from the source - #for now we only copy across if nothing set.. - #todo - bring across defaults for empty keys at targets? - #need to keep it simple enough to reason about behaviour easily.. - if {[dict size $copyfrom]} { - if {![dict size $cmd_info]} { - set cmd_info [dict get $copyfrom cmd_info] - } - if {![dict size $doc_info]} { - set doc_info [dict get $copyfrom doc_info] - } - - #foreach fid $record_form_ids { - # #only use elements with matching form id? - # #probably this feature mainly useful for _default anyway so that should be ok - # #cooperative doc sets specified in same file could share via known form ids too - # FORMDISPLAY has keys -header -body - # if {![dict size $F $fid $FORMDISPLAY]} { - # if {[dict exists $copyfrom FORMS $fid FORMDISPLAY]} { - # dict set F $fid FORMDISPLAY [dict get $copyfrom FORMS $fid FORMDISPLAY] - # } - # } - # #TODO - # #create leaders opts vals depending on position of @default line? - # #options on @default line to exclude/include sets??? - #} - } - } - } - form { - # arity system ? - #handle multiple parsing styles based on arities and keyword positions (and/or flags?) - #e.g see lseq manual with 3 different parsing styles. - #aim to produce a table/subtable for each - # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ - # -arities { - # 2 - # {3 anykeys {1 .. 1 to}} - # {4 anykeys {3 by}} - # {5 anykeys {1 .. 1 to 3 by}} - # }\ - # -fallback 1 - # ... - # @parser -synopsis "start 'count' count ??'by'? step?"\ - # -arities { - # {3 anykeys {1 count}} - # } - # ... - # @form -synopsis "count ?'by' step?"\ - # -arities { - # 1 - # {3 anykeys {1 by}} - # } - # - # see also after manual - # @form -arities {1} - # @form -arities { - # 1 anykeys {0 info} - # } - #todo - - #can we generate a form synopsis if -synopsis not supplied? - - #form id can be list of ints|names?, or * - if {[dict exists $at_specs -form]} { - set idlist [dict get $at_specs -form] - if {$idlist eq "*"} { - #* only applies to form ids that exist at the time - set idlist [dict keys $F] - } - set form_ids_active $idlist - } - #new form keys already created if they were needed (done for all records that have -form ) - } - package { - set package_info [dict merge $package_info $at_specs] - } - cmd { - #allow arbitrary - review - set cmd_info [dict merge $cmd_info $at_specs] - } - doc { - set doc_info [dict merge $doc_info $at_specs] - } - formdisplay { - #override the displayed argument table for the form. - #(formdisplay keys -header -body) - #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing - foreach fid $record_form_ids { - tcl::dict::set F $fid FORMDISPLAY [dict merge [tcl::dict::get $F $fid FORMDISPLAY] $at_specs] - } - } - opts { - foreach fid $record_form_ids { - if {[tcl::dict::get $F $fid argspace] eq "values"} { - error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" - } - tcl::dict::set F $fid argspace "options" - set tmp_optspec_defaults [dict get $F $fid OPTSPEC_DEFAULTS] - - foreach {k v} $at_specs { - switch -- $k { - -form { - #review - handled above - } - -any - -arbitrary - - -anyopts { - #set opt_any $v - tcl::dict::set F $fid OPT_ANY $v - } - -min { - dict set F $fid OPT_MIN $v - } - -max { - dict set F $fid OPT_MAX $v - } - -minsize - -maxsize - -range - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted { - #review - only apply to certain types? - tcl::dict::set tmp_optspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_optspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - index { - set v indexexpression - } - none - "" - - - any - ansistring - globstring - list { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_optspec_defaults -type $v - } - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -validationtransform { - #allow overriding of defaults for options that occur later - tcl::dict::set tmp_optspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -multiple - - -prefix { - #check is bool - if {![string is boolean -strict $v]} { - error "punk::args::define - Option '$k' has value '$v'of wrong type in @opts line. Must be boolean @id:$DEF_definition_id" - } - tcl::dict::set tmp_optspec_defaults $k $v - } - default { - set known { -any -anyopts -arbitrary -form -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\ - -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" - } - } - } - tcl::dict::set F $fid OPTSPEC_DEFAULTS $tmp_optspec_defaults - } ;# end foreach record_form_ids - } - leaders { - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] in [list options values]} { - error "punk::args::define - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" - } - set tmp_leaderspec_defaults [dict get $F $fid LEADERSPEC_DEFAULTS] - - foreach {k v} $at_specs { - switch -- $k { - -form { - #review - handled above - } - -min - - -minvalues { - if {$v < 0} { - error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MIN $v - #if {$leader_max == 0} { - # set leader_max -1 - #} - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::define - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MAX $v - } - -choiceprefix - - -choicerestricted { - if {![string is boolean -strict $v]} { - error "punk::args::define - invalid type of value '$v' for key '$k' in @leaders line. Must be boolean @id:$DEF_definition_id" - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -minsize - -maxsize - -range - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefixdenylist - -choiceprefixreservelist - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -choiceinfo - -choicelabels { - if {[llength $v] %2 != 0} { - error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - #-choicegroups? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_leaderspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - index { - set v indexexpression - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform { - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -multiple { - if {![string is boolean -strict $v]} { - error "punk::args::define - invalid type of value '$v' for key '$k' in @leaders line. Must be boolean @id:$DEF_definition_id" - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -unnamed { - if {![string is boolean -strict $v]} { - error "punk::args::define - invalid type of value '$v' for key '$k' in @leaders line. Must be boolean @id:$DEF_definition_id" - } - dict set F $fid LEADER_UNNAMED $v - } - -ensembleparameter { - #review - tcl::dict::set tmp_leaderspec_defaults $k $v - #error "punk::args::define - -ensembleparameter not supported as a default for @leaders - only valid on actual leader arguments" - } - default { - set known { -min -form -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\ - -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted\ - -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - -unnamed\ - } - error "punk::args::define - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid LEADERSPEC_DEFAULTS $tmp_leaderspec_defaults - - } ;#end foreach record_form_ids - - } - values { - foreach fid $record_form_ids { - dict set F $fid argspace "values" - - set tmp_valspec_defaults [dict get $F $fid VALSPEC_DEFAULTS] - - foreach {k v} $at_specs { - switch -- $k { - -form { - #review - handled above - } - -min - - -minvalues { - if {$v < 0} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" - } - #set val_min $v - dict set F $fid VAL_MIN $v - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" - } - #set val_max $v - dict set F $fid VAL_MAX $v - } - -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_valspec_defaults $k $v - } - -choiceinfo - -choicegroups { - if {[llength $v] % 2 != 0} { - error "punk::args::define - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - # -choicegroups ?? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_valspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - index { - set v indexexpression - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -multiple { - if {![string is boolean -strict $v]} { - error "punk::args::define - invalid type of value '$v' for key '$k' in @values line. Must be boolean @id:$DEF_definition_id" - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform { - tcl::dict::set tmp_valspec_defaults $k $v - } - -unnamed { - if {![string is boolean -strict $v]} { - error "punk::args::define - invalid type of value '$v' for key '$k' in @values line. Must be boolean @id:$DEF_definition_id" - } - dict set F $fid VAL_UNNAMED $v - } - default { - set known { -min -form -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\ - -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted\ - -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - -unnamed\ - } - error "punk::args::define - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid VALSPEC_DEFAULTS $tmp_valspec_defaults - } - - } - seealso { - #todo! - #like @doc, except displays in footer, multiple - sub-table? - set seealso_info [dict merge $seealso_info $at_specs] - } - keywords { - #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? - set keywords_info [dict merge $keywords_info $at_specs] - } - default { - error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @formdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" - } - } - #record_type directive - continue - } elseif {$firstchar eq "-"} { - set argname $firstword - set argdef_values $record_values - tcl::dict::set argdef_values -ARGTYPE option - - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - dict set F $fid argspace "options" - } elseif {[dict get $F $fid argspace] eq "values"} { - error "punk::args::define - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" - } - set record_type option - dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] - #lappend opt_names $argname - } - - set is_opt 1 - } else { - set argname $firstword - if {$firstchar eq "@"} { - #allow basic @@ escaping for literal argname that begins with @ - set argname [tcl::string::range $argname 1 end] - } - - set argdef_values $record_values - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - set record_type leader - tcl::dict::set argdef_values -ARGTYPE leader - #lappend leader_names $argname - set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] - if {$argname ni $temp_leadernames} { - lappend temp_leadernames $argname - tcl::dict::set F $fid LEADER_NAMES $temp_leadernames - } else { - #This can happen if the definition has repeated values - error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" - } - - if {[dict get $F $fid LEADER_MAX] >= 0} { - if {[dict get $F $fid LEADER_MAX] < [llength $temp_leadernames]} { - puts stderr "punk::args::resolve warning arg $argname LEADER_MAX == [dict get $F $fid LEADER_MAX] but [llength $temp_leadernames] leader names found @id:$DEF_definition_id" - dict set F $fid LEADER_MAX [llength $temp_leadernames] - } - } - } else { - set record_type value - tcl::dict::set argdef_values -ARGTYPE value - set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] - if {$argname ni $temp_valnames} { - lappend temp_valnames $argname - tcl::dict::set F $fid VAL_NAMES $temp_valnames - } else { - error "punk::args::define - arg $argname already present as value in '$rec' (command form:'$fid') @id:$DEF_definition_id" - } - #lappend val_names $argname - if {[dict get $F $fid VAL_MAX] >= 0} { - if {[dict get $F $fid VAL_MAX] < [llength $temp_valnames]} { - puts stderr "punk::args::resolve warning arg $argname VAL_MAX == [dict get $F $fid VAL_MAX] but [llength $temp_valnames] value names found @id:$DEF_definition_id" - dict set F $fid VAL_MAX [llength $temp_valnames] - } - } - } - } - - set is_opt 0 - } - - - #assert - we only get here if it is a value or flag specification line. - #assert argdef_values has been set to the value of record_values - - foreach fid $record_form_ids { - if {$is_opt} { - set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS] - } else { - if {[dict get $F $fid argspace] eq "values"} { - set spec_merged [dict get $F $fid VALSPEC_DEFAULTS] - } else { - set spec_merged [dict get $F $fid LEADERSPEC_DEFAULTS] - } - } - - # -> argopt argval - foreach {spec specval} $argdef_values { - #literal-key switch - bytecompiled to jumpTable - switch -- $spec { - -form { - - } - -type { - #todo - could be a list e.g {any int literal(Test)} - #case must be preserved in literal bracketed part - set typelist [list] - foreach typespec $specval { - set lc_typespec [tcl::string::tolower $typespec] - #normalize here so we don't have to test during actual args parsing in main function - switch -- $lc_typespec { - int - integer { - lappend typelist int - } - double - float { - #review - user may wish to preserve 'float' in help display - consider how best to implement - lappend typelist double - } - bool - boolean { - lappend typelist bool - } - char - character { - lappend typelist char - } - dict - dictionary { - lappend typelist dict - } - index - indexexpression { - lappend typelist indexexpression - } - "" - none { - if {$is_opt} { - #review - are we allowing clauses for flags? - #e.g {-flag -type {int int}} - #this isn't very tcl like, where we'd normally mark the flag with -multiple true and - # instead require calling as: -flag -flag - #It seems this is a reasonably rare/unlikely requirement in most commandline tools. - - if {[llength $typelist] > 1} { - #makes no sense to have 'none' in a clause - error "punk::args::define - invalid -type '$specval' for flag '$argname' ('none' in multitype) @id:$DEF_definition_id" - } - #tcl::dict::set spec_merged -type none - lappend typelist none - 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. - } - } else { - #-solo only valid for flags - error "punk::args::define - invalid -type 'none' for positional argument '$argname' (only valid for flags/options) @id:$DEF_definition_id" - } - } - any - anything { - lappend typelist any - } - ansi - ansistring { - lappend typelist ansistring - } - string - globstring { - lappend typelist $lc_typespec - } - literal { - #value is the name of the argument - if {$is_opt} { - error "punk::args::define - invalid -type 'literal' for flag argument '$argname' @id:$DEF_definition_id" - } - lappend typelist literal - } - default { - if {[string match literal* $lc_typespec]} { - set literal_tail [string range $typespec 7 end] - lappend typelist literal$literal_tail - } else { - #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW - #tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - lappend typelist $lc_typespec - } - } - } - } - tcl::dict::set spec_merged -type $typelist - } - -solo - -range - - -choices - -choicegroups - -choicemultiple - -choicecolumns - - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted - -choicelabels - -choiceinfo - - -minsize - -maxsize - -nocase - -multiple - - -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - - -regexprepass - -regexprefail - -regexprefailmsg - { - #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines - #review -solo 1 vs -type none ? conflicting values? - tcl::dict::set spec_merged $spec $specval - } - -default { - tcl::dict::set spec_merged -default $specval - if {![dict exists $argdef_values -optional]} { - tcl::dict::set spec_merged -optional 1 - } - } - -optional { - tcl::dict::set spec_merged -optional $specval - } - -ensembleparameter { - #review - only leaders? - tcl::dict::set spec_merged $spec $specval - } - -prefix { - #for flags/options - tcl::dict::set spec_merged $spec $specval - } - -validationtransform { - #string is dict only 8.7/9+ - if {[llength $specval] % 2} { - error "punk::args::define - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" - } - dict for {tk tv} $specval { - switch -- $tk { - -function - -type - -minsize - -maxsize - -range { - } - default { - set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? - error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" - } - } - } - - } - default { - if {[string match ref-* $spec]} { - #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) - #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. - if {![tcl::dict::exists $refs $specval]} { - puts stderr "punk::args::define argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" - } else { - set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" - if {$targetswitch eq "-*"} { - set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id - } else { - if {[tcl::dict::exists $refs $specval $targetswitch]} { - tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] - } else { - puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" - } - } - } - } else { - set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups\ - -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted\ - -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - -ensembleparameter\ - ] - error "punk::args::define - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" - } - } - } - } ;# end foreach {spec specval} argdef_values - - - if {$is_opt} { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - if {[tcl::dict::get $spec_merged -type] eq "none"} { - #JJJJ - dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname] - } - } else { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - tcl::dict::set F $fid ARG_INFO $argname $spec_merged - #review existence of -default overriding -optional - #if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} {} - if {![tcl::dict::get $spec_merged -optional]} { - if {$is_opt} { - set temp_opt_required [dict get $F $fid OPT_REQUIRED] - lappend temp_opt_required $argname - dict set F $fid OPT_REQUIRED $temp_opt_required - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - set temp_leader_required [dict get $F $fid LEADER_REQUIRED] - lappend temp_leader_required $argname - dict set F $fid LEADER_REQUIRED $temp_leader_required - } else { - set temp_val_required [dict get $F $fid VAL_REQUIRED] - lappend temp_val_required $argname - dict set F $fid VAL_REQUIRED $temp_val_required - } - } - } - - - if {[tcl::dict::exists $spec_merged -default]} { - if {$is_opt} { - #tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] - tcl::dict::set F $fid OPT_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } else { - #tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] - tcl::dict::set F $fid VAL_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } - } - } - } ;# end foreach fid record_form_ids - - } ;# end foreach rec $records - - - #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { - # variable id_counter - # set DEF_definition_id "autoid_[incr id_counter]" - #} - - - #now cycle through ALL forms not just form_ids_active (record_form_ids) - dict for {fid formdata} $F { - # REVIEW - #no values specified - we can allow last leader to be multiple - foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { - error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" - } - } - - #todo - disallow any -multiple == true entries if any leaders have -multiple == true? - #(creates parsing ambiguity) - #ambiguity could be resolved if at least one required option/flag eg -- - #ambiguities could theoretically also be resolved with required literals or choices - or even based on argument type - #(overcomplex? todo see if any core/tcllib commands work like that) - - #only allow a single entry within VAL_NAMES to have -multiple == true - #example of command with non-trailing -multiple == true is core command: 'file copy ?-force? ?--? source ?source?... targetDir - set val_multiples 0 - foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { - if {$val_multiples > 0} { - error "bad setting -multiple true on argument spec for value '$valname' in command form:'$fid'. Only a single value argument specification can be marked with -multiple true @id:$DEF_definition_id" - } - incr val_multiples - } - } - - #todo - document that ambiguities in API are likely if both @leaders and @values used - #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) - - - dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata LEADERSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata OPTSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata VALSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - - - - - #todo - precalculate a set of 'arity' entries for each form - #We want a structure for the arg parser to get easy access and make a fast decision on which form applies - #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? - #1) after ms (1 1) - #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? - #3) after cancel id (2 2) - #4) after cancel script ?script...? (2 -1) - #5) after idle script ?script...? (1 -1) - #6) after info ?id? (1 2) - - #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) - - #in the above case we have no unique total_arity - #we would also want to consider values when selecting - #e.g given the invalid command "after cancel" - # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. - - - - set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands - #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use - #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form - #e.g commandline completion could show list of synopsis entries to select from - - set form_info [dict create] - dict for {fid fdict} $F { - dict set form_info $fid {} - dict for {optk optv} $fdict { - if {[string match -* $optk]} { - dict set form_info $fid $optk $optv - } - } - } - - set argdata_dict [tcl::dict::create\ - id $DEF_definition_id\ - cmd_info $cmd_info\ - doc_info $doc_info\ - package_info $package_info\ - seealso_info $seealso_info\ - id_info $id_info\ - FORMS $F\ - form_names [dict keys $F]\ - form_info $form_info\ - ] - - tcl::dict::set argdata_cache $cache_key $argdata_dict - if {$is_dynamic} { - #also cache resolved version - tcl::dict::set argdata_cache [list $optionspecs] $argdata_dict - } - - #tcl::dict::set id_cache_rawdef $DEF_definition_id $args - #puts "xxx:$result" - return $argdata_dict - } - - #return raw definition list as created with 'define' - # - possibly with unresolved dynamic parts - proc raw_def {id} { - variable id_cache_rawdef - set realid [real_id $id] - if {![dict exists $id_cache_rawdef $realid]} { - return "" - } - return [tcl::dict::get $id_cache_rawdef $realid] - } - - - namespace eval argdoc { - variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @formdisplay @seealso @leaders @opts @values leaders opts values} - variable resolved_def_TYPE_CHOICEGROUPS { - directives {@id @package @cmd @ref @doc @formdisplay @seealso} - argumenttypes {leaders opts values} - remaining_defaults {@leaders @opts @values} - } - - lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { - @id -id ::punk::args::resolved_def - @cmd -name punk::args::resolved_def -help\ - "Resolves or retrieves the previously resolved definition and - uses the 'spec' form to build a response in definition format. - - Pulling argument definition data from another function is a form - of tight coupling to the other function that should be done with - care. - - Note that the directives @leaders @opts @values may appear multiple - times in a source definition - applying defaults for arguments that - follow. When retrieving these - there is only a single result for - each that represents the defaults after all have been applied. - When retrieving -types * each of these will be positioned before - the arguments of that type - but this doesn't mean there was a single - leading directive for this argument type in the source definition. - Each argument has already had its complete specification recorded in - its own result. - - When manually specifying -types, the order @leaders then @opts then - @values must be maintained - but if they are placed before their - corresponding arguments, they will not affect the retrieved arguments - as these arguments are already fully spec'd. The defaults from the - source can be removed by adding @leaders, @opts @values to the - -antiglobs list, but again - this won't affect the existing arguments. - Each argument can have members of its spec overridden using the - -override dictionary. - " - @leaders -min 0 -max 0 - @opts - -return -default text -choices {text dict} - -form -default 0 -help\ - "Ordinal index or name of command form" - - #no restriction on number of types/repetitions? - -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} - -antiglobs -default {} -type list -help\ - "Glob patterns for directive or argument/flags to - be suppressed" - -override -type dict -optional 1 -default "" -help\ - "dict of dicts. Key in outer dict is the name of a - directive or an argument. Inner dict is a map of - overrides/additions (- ...) for that line. - " - @values -min 1 -max -1 - id -type string -help\ - "identifer for a punk::args definition - This will usually be a fully-qualifed - path for a command name" - pattern -type string -optional 1 -default * -multiple 1 -help\ - "glob-style patterns for retrieving value or switch - definitions. - - If -type is * and pattern is * the entire definition including - directive lines will be returned in line form. - (directives are lines beginning with - @ e.g @id, @cmd etc) - - if -type is leaders,opts or values matches from that type - will be returned. - - if -type is another directive such as @id, @doc etc the - patterns are ignored. - - " - }]] - } - - - proc resolved_def {args} { - #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. - set opts [dict create\ - -return text\ - -types {}\ - -form 0\ - -antiglobs {}\ - -override {}\ - ] - if {[llength $args] < 1} { - #must have at least id - punk::args::parse $args withid ::punk::args::resolved_def - return - } - set patterns [list] - - #a definition id must not begin with "-" ??? review - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {$a in {-type -types}} { - incr i - dict set opts -types [lindex $args $i] - } elseif {[string match -* $a]} { - incr i - dict set opts $a [lindex $args $i] - } else { - set id [lindex $args $i] - set patterns [lrange $args $i+1 end] - break - } - if {$i == [llength $args]-1} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - if {![llength $patterns]} { - set patterns [list *] - } - dict for {k v} $opts { - #set fullk [tcl::prefix::match -error "" {-return -form -types -antiglobs -override} $k] - switch -- $k { - -return - -form - -types - -antiglobs - -override {} - default { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - } - set typelist [dict get $opts -types] - if {[llength $typelist] == 0} { - set typelist {*} - } - foreach type $typelist { - if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - - - variable id_cache_rawdef - set realid [real_id $id] - if {$realid eq ""} { - return - } - - set deflist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] - - set opt_form [dict get $opts -form] - if {[string is integer -strict $opt_form]} { - set formname [lindex [dict get $specdict form_names] $opt_form] - } else { - set formname $opt_form - } - set opt_override [dict get $opts -override] - set opt_return [dict get $opts -return] - - #set arg_info [dict get $specdict ARG_INFO] - set arg_info [dict get $specdict FORMS $formname ARG_INFO] - set argtypes [dict create leaders leader opts option values value] - - set opt_antiglobs [dict get $opts -antiglobs] - set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] - set suppressed_directives [list] - set suppressed_args [list] - foreach ag $opt_antiglobs { - foreach d $directives { - if {[string match $ag $d]} { - lappend suppressed_directives $d - } - } - foreach argname [dict keys $arg_info] { - if {[string match $ag $argname]} { - lappend suppressed_args $argname - } - } - } - set suppressed_directives [lsort -unique $suppressed_directives] - set suppressed_args [lsort -unique $suppressed_args] - - set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] - - set globbed [list] - foreach pat $patterns { - set matches [dict keys $arg_info $pat] - lappend globbed {*}$matches - } - set globbed [lsort -unique $globbed] - #maintain order of original arg_info keys in globbed results - set ordered_globbed [list] - foreach a [dict keys $arg_info] { - if {$a ni $ordered_globbed && $a in $globbed} { - lappend ordered_globbed $a - } - } - set included_args [punk::args::system::punklib_ldiff $ordered_globbed $suppressed_args] - - set result "" - set resultdict [dict create] - foreach type $typelist { - switch -exact -- $type { - * { - if {"@id" in $included_directives} { - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - foreach directive {@package @cmd @doc @seealso} { - set dshort [string range $directive 1 end] - if {"$directive" in $included_directives} { - if {[dict exists $opt_override $directive]} { - append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict ${dshort}_info]" - dict set resultdict $directive [dict get $specdict ${dshort}_info] - } - } - } - - #todo @formdisplay - - - #output ordered by leader, option, value - foreach pseudodirective {leaders opts values} tp {leader option value} { - set directive "@$pseudodirective" - switch -- $directive { - @leaders {set defaults_key LEADERSPEC_DEFAULTS} - @opts {set defaults_key OPTSPEC_DEFAULTS} - @values {set defaults_key VALSPEC_DEFAULTS} - } - - if {"$directive" in $included_directives} { - if {[dict exists $opt_override "$directive"]} { - append result \n "$directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict FORMS $formname $defaults_key]" - dict set resultdict $directive [dict get $specdict FORMS $formname $defaults_key] - } - } - - if {$pseudodirective in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq $tp} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "\"$m\" [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "\"$m\" $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - - } - @id { - if {"@id" in $included_directives} { - #only a single id record can exist - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - } - @package - @cmd - @doc - @seealso { - if {"$type" in $included_directives} { - set tp [string range $type 1 end] ;# @package -> package - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict ${tp}_info]" - dict set resultdict $type [dict get $specdict ${tp}_info] - } - } - #todo @formdisplay - } - @leaders - @opts - @values { - #these are the active defaults for further arguments - if {"$type" in $included_directives} { - switch -- $type { - @leaders {set defaults_key LEADERSPEC_DEFAULTS} - @opts {set defaults_key OPTSPEC_DEFAULTS} - @values {set defaults_key VALSPEC_DEFAULTS} - } - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS]" - dict set resultdict $type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] - } - } - } - leaders - opts - values { - #pseudo-directives - if {$type in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "\"$m\" [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "\"$m\" $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - default { - } - } - if {$opt_return eq "text"} { - return $result - } else { - return $resultdict - } - } - } - - proc resolved_def_values {id {patternlist *}} { - variable id_cache_rawdef - set realid [real_id $id] - if {$realid ne ""} { - set deflist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [resolve {*}$deflist] - set arg_info [dict get $specdict ARG_INFO] - set valnames [dict get $specdict VAL_NAMES] - set result "" - if {$patternlist eq "*"} { - foreach v $valnames { - set def [dict get $arg_info $v] - set def [dict remove $def -ARGTYPE] - append result \n "$v $def" - } - return $result - } else { - foreach pat $patternlist { - set matches [dict keys $arg_info $pat] - set matches [lsearch -all -inline -glob $valnames $pat] - foreach m $matches { - set def [dict get $arg_info $m] - set def [dict remove $def -ARGTYPE] - append result \n "$m $def" - } - } - return $result - } - } - } - #proc resolved_def_leaders ?? - #proc resolved_def_opts ?? - - proc get_spec {id} { - set deflist [raw_def $id] - if {$deflist eq ""} { - return - } - return [resolve {*}$deflist] - #if {[id_exists $id]} { - # return [resolve {*}[raw_def $id]] - #} - } - proc is_dynamic {id} { - variable id_cache_rawdef - variable rawdef_cache - set deflist [raw_def $id] - if {[dict exists $rawdef_cache $deflist -dynamic]} { - return [dict get $rawdef_cache $deflist -dynamic] - } - return [rawdef_is_dynamic $deflist] - #@dynamic only has meaning as 1st element of a def in the deflist - } - - #@id must be within first 4 lines of a block - or assign auto - #review - @dynamic block where -id not explicitly set? - disallow? - proc rawdef_id {rawdef} { - set id "" - foreach d $rawdef { - foreach ln [lrange [split $d \n] 0 4] { - if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { - if {$firstword eq "@id"} { - if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { - set id [dict get $rest -id] - break - } - } - } - } - if {$id ne ""} { - break - } - } - if {$id eq "" || [string tolower $id] eq "auto"} { - variable id_counter - set id "autoid_[incr id_counter]" - } - #puts "==>id: $id" - return $id - } - #test the rawdef for @dynamic directive - proc rawdef_is_dynamic {rawdef} { - #temporary - old way - set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] - if {$flagged_dynamic} { - return true - } - foreach d $rawdef { - if {[regexp {\s*(\S+)} $d _match firstword]} { - if {$firstword eq "@dynamic"} { - return true - } - } - } - return false - } - - variable aliases - set aliases [dict create] - - lappend PUNKARGS [list { - @id -id ::punk::args::get_ids - @cmd -name punk::args::get_ids -help\ - "return list of ids for argument definitions" - @values -min 0 -max 1 - match -default * -help\ - "exact id or glob pattern for ids" - }] - proc get_ids {{match *}} { - variable id_cache_rawdef - variable aliases - return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] - } - - #we don't automatically test for (autodef)$id - only direct ids and aliases - proc id_exists {id} { - variable aliases - if {[tcl::dict::exists $aliases $id]} { - return 1 - } - variable id_cache_rawdef - tcl::dict::exists $id_cache_rawdef $id - } - proc set_alias {alias id} { - variable aliases - dict set aliases $alias $id - } - proc unset_alias {alias} { - variable aliases - dict unset aliases $alias - } - proc get_alias {alias} { - variable aliases - if {[dict exists $aliases $alias]} { - return [tcl::dict::get $aliases $alias] - } - } - - proc real_id {id} { - variable id_cache_rawdef - variable aliases - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } else { - set check_updates [list [namespace qualifiers $id]] - #puts stderr "---->real_id '$id' update_definitions $check_updates" - if {![llength [update_definitions $check_updates]]} { - #nothing new loaded - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } else { - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } - } - } - - proc status {} { - upvar ::punk::args::register::NAMESPACES registered - upvar ::punk::args::register::loaded_packages loaded_packages - upvar ::punk::args::register::loaded_info loaded_info - upvar ::punk::args::register::scanned_packages scanned_packages - upvar ::punk::args::register::scanned_info scanned_info - set result "" - # [format %-${w0}s $idtail] - set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] - append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n - set width_c2 [string length "Scanned_ids"] - set width_c3 [string length "Scantime_us"] - set width_c4 [string length "Loaded_defs"] - set width_c5 [string length "Loadtime_us"] - set count_unloaded 0 - set count_loaded 0 - foreach ns $registered { - if {$ns in $scanned_packages} { - set ids [dict get $scanned_info $ns idcount] - set scan_us [dict get $scanned_info $ns time] - } else { - set ids "" - set scan_us "" - } - if {$ns in $loaded_packages} { - incr count_loaded - set ldefs [dict get $loaded_info $ns defcount] - set load_us [dict get $loaded_info $ns time] - } else { - incr count_unloaded - set ldefs "" - set load_us "" - } - append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n - } - append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" - return $result - } - - #scanned_packages (list) - #namespace_docpackages (dict) - proc update_definitions {{nslist *}} { - #puts "----> update_definitions '$nslist'" - if {[set gposn [lsearch $nslist {}]] >= 0} { - lset nslist $gposn :: - } - upvar ::punk::args::register::NAMESPACES registered ;#list - upvar ::punk::args::register::loaded_packages loaded_packages ;#list - upvar ::punk::args::register::loaded_info loaded_info ;#dict - upvar ::punk::args::register::scanned_packages scanned_packages ;#list - upvar ::punk::args::register::scanned_info scanned_info ;#dict - upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict - - - #puts stderr "-->update_definitions '$nslist'" - #needs to run quickly - especially when no package namespaces to be scanned for argdefs - #e.g - gets called for each subcommand of an ensemble (could be many) - # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. - #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. - # -- --- --- --- --- --- - # common-case fast-path - - if {[llength $loaded_packages] == [llength $registered]} { - #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. - #assert - if all are registered - then all have been scanned - return {} - } - # -- --- --- --- --- --- - - set unscanned [punklib_ldiff $registered $scanned_packages] - if {[llength $unscanned]} { - foreach pkgns $unscanned { - set idcount 0 - set ts_start [clock microseconds] - if {[info exists ${pkgns}::PUNKARGS]} { - set seen_documentedns [list] ;#seen per pkgns - foreach definitionlist [set ${pkgns}::PUNKARGS] { - #namespace eval $evalns [list punk::args::define {*}$definitionlist] - set id [rawdef_id $definitionlist] - if {[string match autoid_* $id]} { - puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" - puts stderr "definition:\n" - foreach d $definitionlist { - set out "" - foreach ln [split $d \n] { - append out " " $ln \n - } - puts $out - } - continue - } - #todo - detect duplicate ids (last will silently win.. should be reported somewhere) - incr idcount - set documentedns [namespace qualifiers $id] - if {$documentedns eq ""} {set documentedns ::} - if {$documentedns ni $seen_documentedns} { - #don't add own ns as a key in namespace_docpackages - if {$documentedns ne $pkgns} { - dict lappend namespace_docpackages $documentedns $pkgns - } - lappend seen_documentedns $documentedns - } - } - } - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - dict set scanned_info $pkgns [dict create time $diff idcount $idcount] - #we count it as scanned even if PUNKARGS didn't exist - #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) - lappend scanned_packages $pkgns - } - } - - - - if {"*" in $nslist} { - set needed [punklib_ldiff $registered $loaded_packages] - } else { - set needed [list] - foreach pkgns $nslist { - if {![string match ::* $pkgns]} { - puts stderr "warning: update_definitions received unqualified ns: $pkgns" - set pkgns ::$pkgns - } - if {$pkgns in $registered && $pkgns ni $loaded_packages} { - lappend needed $pkgns - } - #argdoc sub namespace is a standard place to put defs that match the namespace below - #(generally the PUNKARGS in a namespace should apply to own ns) - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { - lappend needed $docns - } - } - if {[dict exists $namespace_docpackages $pkgns]} { - #this namespace has other argdef sources - foreach docns [dict get $namespace_docpackages $pkgns] { - if {$docns ni $loaded_packages} { - lappend needed $docns - } - } - } - } - } - - - - set newloaded [list] - foreach pkgns $needed { - #puts stderr "update_definitions Loading: $pkgns" - set ts_start [clock microseconds] - set def_count 0 - if {![catch { - if {[info exists ${pkgns}::PUNKARGS]} { - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - namespace eval ${pkgns}::argdoc { - set epath [namespace path] - set pkgns [namespace parent] - if {$pkgns ni $epath} { - namespace path [list {*}$epath $pkgns] ;#add to tail - } - - } - set evalns $docns - } else { - set evalns $pkgns - } - foreach definitionlist [set ${pkgns}::PUNKARGS] { - namespace eval $evalns [list punk::args::define {*}$definitionlist] - incr def_count - } - } - - #process list of 2-element lists - if {[info exists ${pkgns}::PUNKARGS_aliases]} { - foreach adef [set ${pkgns}::PUNKARGS_aliases] { - punk::args::set_alias {*}$adef - } - } - } errMsg]} { - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - lappend loaded_packages $pkgns - lappend newloaded $pkgns - dict set loaded_info $pkgns [dict create time $diff defcount $def_count] - } else { - puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" - } - } - return $newloaded - } - - #for use within get_dict only - #This mechanism gets less-than-useful results for oo methods - #e.g {$obj} - proc Get_caller {} { - #set call_level -3 ;#for get_dict call - set call_level -4 - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - #puts "-->$cmdinfo" - #puts "-->[tcl::info::frame -3]" - while {[string last \n $cmdinfo] >= 1} { - #looks like a script - haven't gone up far enough? - #(e.g patternpunk oo system: >punk . poses -invalidoption) - incr call_level -1 - if {[catch { - set nextup [tcl::info::frame $call_level] - } ]} { - break - } - set cmdinfo [tcl::dict::get $nextup cmd] - set caller [regexp -inline {\S+} $cmdinfo] - if {[interp alias {} $caller] ne ""} { - #puts "found alias for caller $caller to [interp alias {} $caller]" - #see if we can go further - incr call_level -1 - if {[catch { - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - } errM ]} { - puts "err: $errM" - break - } - } - } - set caller [regexp -inline {\S+} $cmdinfo] - if {$caller eq "namespace"} { - # review - message? - set cmdinfo "Get_caller (punk::args::get_dict?) called from namespace" - } - return $cmdinfo - } - - - # -------------------------------------- - #test of Get_caller - lappend PUNKARGS [list { - @id -id ::punk::args::test1 - @values -min 0 -max 0 - }] - proc test_get_dict {args} { - punk::args::get_dict [punk::args::raw_def ::punk::args::test1] $args - } - proc test_get_by_id {args} { - punk::args::get_by_id ::punk::args::test1 $args - } - #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. - proc test_callers {args} { - if {![llength $args]} { - puts "these test functions accept no arguments" - puts "Call with arg(s) to compare error output" - } - - if {[catch {test_get_dict {*}$args} errM]} { - puts $errM - } - puts "------------" - if {[catch {test_get_by_id {*}$args} errM]} { - puts $errM - } - return done - } - # -------------------------------------- - - set map "" - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::arg_error - @cmd -name punk::args::arg_error -help\ - "Generates a table (by default) of usage information for a command. - A trie system is used to create highlighted prefixes for command - switches and for subcommands or argument/switch values that accept - a defined set of choices. These prefixes match the mechanism used - to validate arguments (based on tcl::prefix::match). - - This function is called during the argument parsing process - (if the definition is not only being used for documentation) - It is also called by punk::args::usage which is in turn - called by the punk::ns introspection facilities which creates - on the fly definitions for some commands such as ensembles and - oo objects where a manually defined one isn't present. - " - @leaders -min 2 -max 2 - msg -type string -help\ - "Error message to display immediately prior to usage table. - May be empty string to just display usage. - " - spec_dict -type dict -help\ - "Dictionary of argument specifications. - This is the internal format parsed from - the textual definition. It contains the data - organised/optimised to allow the final arg - parser/validator to make decisions. - " - @opts - -badarg -type string -help\ - "name of an argument to highlight" - -parsedargs -type dict -help\ - "Result of successful punk::pargs::parse - (currently only looks at 'received')" - -aserror -type boolean -help\ - "If true, the usage table is raised as an error message, - otherwise it is returned as a value." - -return -choices {string table tableobject} -choicelabels { - string "no table layout" - tableobject "table object cmd" - table "full table layout" - } - -scheme -default error -choices {nocolour info error} - -form -default 0 -help\ - "Ordinal index or name of command form" - }] ] - - if {[catch {package require punk::ansi}]} { - proc punk::args::a {args} {} - proc punk::args::a+ {args} {} - } else { - namespace eval ::punk::args { - namespace import ::punk::ansi::a ::punk::ansi::a+ - } - } - variable arg_error_CLR - array set arg_error_CLR {} - set arg_error_CLR(errormsg) [a+ brightred] - set arg_error_CLR(title) "" - set arg_error_CLR(check) [a+ brightgreen] - set arg_error_CLR(solo) [a+ brightcyan] - set arg_error_CLR(choiceprefix) [a+ underline] - set arg_error_CLR(badarg) [a+ brightred] - set arg_error_CLR(goodarg) [a+ green strike] - set arg_error_CLR(goodchoice) [a+ reverse] - set arg_error_CLR(linebase_header) [a+ white] - set arg_error_CLR(cmdname) [a+ brightwhite] - set arg_error_CLR(groupname) [a+ bold] - set arg_error_CLR(ansiborder) [a+ bold] - set arg_error_CLR(ansibase_header) [a+ bold] - set arg_error_CLR(ansibase_body) [a+ white] - variable arg_error_CLR_nocolour - array set arg_error_CLR_nocolour {} - set arg_error_CLR_nocolour(errormsg) [a+ bold] - set arg_error_CLR_nocolour(title) [a+ bold] - set arg_error_CLR_nocolour(check) "" - set arg_error_CLR_nocolour(solo) "" - set arg_error_CLR_nocolour(badarg) [a+ reverse] ;#? experiment - set arg_error_CLR_nocolour(goodarg) [a+ strike] - set arg_error_CLR_nocolour(cmdname) [a+ bold] - set arg_error_CLR_nocolour(linebase_header) "" - set arg_error_CLR_nocolour(linebase) "" - set arg_error_CLR_nocolour(ansibase_body) "" - variable arg_error_CLR_info - array set arg_error_CLR_info {} - set arg_error_CLR_info(errormsg) [a+ brightred bold] - set arg_error_CLR_info(title) [a+ brightyellow bold] - set arg_error_CLR_info(check) [a+ brightgreen bold] - set arg_error_CLR_info(choiceprefix) [a+ brightgreen bold] - set arg_error_CLR_info(groupname) [a+ cyan bold] - set arg_error_CLR_info(ansiborder) [a+ brightcyan bold] - set arg_error_CLR_info(ansibase_header) [a+ cyan] - set arg_error_CLR_info(ansibase_body) [a+ white] - variable arg_error_CLR_error - array set arg_error_CLR_error {} - set arg_error_CLR_error(errormsg) [a+ brightred bold] - set arg_error_CLR_error(title) [a+ brightcyan bold] - set arg_error_CLR_error(check) [a+ brightgreen bold] - set arg_error_CLR_error(choiceprefix) [a+ brightgreen bold] - set arg_error_CLR_error(groupname) [a+ cyan bold] - set arg_error_CLR_error(ansiborder) [a+ brightyellow bold] - set arg_error_CLR_error(ansibase_header) [a+ yellow] - set arg_error_CLR_error(ansibase_body) [a+ white] - - - #bas ic recursion blocker - variable arg_error_isrunning 0 - proc arg_error {msg spec_dict args} { - #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. - #accept an option here so that we can still use full output for usage requests. - #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args - #Development/experimentation may be done with full table-based error reporting - but for production release it - #may be desirable to reduce overhead on catches. - #consider per-namespace or namespace-tree configurability. - #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due - #to resource availability etc - so the slower error generation time may not always be a problem. - #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling - #code which has no use for the enhanced error info. - #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. - #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system - #todo - #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error - #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) - - #todo - document unnamed leaders and unnamed values where -min and/or -max specified - #e.g punk::args::parse {} withdef {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} - #only |?-x?|string|... is shown in the output table. - #should be something like: - # |arg | - # |?-x? | - # |arg | - # |?arg...?| - # Where/how to specify counts? - #also.. - # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? - # - - - #limit colours to standard 16 so that themes can apply to help output - variable arg_error_isrunning - if {$arg_error_isrunning} { - error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" - } - - if {[llength $args] %2 != 0} { - error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" - } - - set arg_error_isrunning 1 - - set badarg "" - set parsedargs [dict create] ;#dict with keys: leaders,opts,values,received,solos,multis (as from punk::args::parse) - set goodargs [list] - set returntype table ;#table as string - set as_error 1 ;#usual case is to raise an error - set scheme error - set form 0 - dict for {k v} $args { - set fullk [tcl::prefix::match -error "" {-badarg -parsedargs -aserror -return -scheme -form} $k] - switch -- $fullk { - -badarg { - set badarg $v - } - -parsedargs { - #todo? - dict for {set setinfo} $v { - switch -- $set { - received { - foreach {r rpos} $setinfo { - if {$r ni $goodargs} { - lappend goodargs $r - } - } - } - } - } - set parsedargs $v - } - -aserror { - if {![string is boolean -strict $v]} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" - } - set as_error $v - } - -scheme { - set scheme $v - } - -return { - if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" - } - set returntype $v - } - -form { - set form $v - } - default { - set arg_error_isrunning 0 - error "arg_error invalid option $k. Known_options: -badarg -parsedargs -aserror -scheme -return -form" - } - } - } - #todo - scheme - use config and iterm toml definitions etc - switch -- $scheme { - "" - -nocolor - -nocolour { - set scheme nocolour - } - info - error {} - default { - set scheme na - } - } - set formnames [dict get $spec_dict form_names] - if {[string is integer -strict $form]} { - if {$form < 0 || $form > [llength $formnames]-1} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" - } - set selected_forms [list [lindex $formnames $form]] - } else { - if {$form eq "*"} { - set selected_forms $formnames - } else { - if {$form in $formnames} { - set selected_forms [list $form] - } else { - set arg_error_isrunning 0 - error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" - } - } - } - - - #hack some basics for now. - #for coloured schemes - use bold as well as brightcolour in case colour off. - upvar ::punk::args::arg_error_CLR CLR - - switch -- $scheme { - nocolour { - variable arg_error_CLR_nocolour - array set CLR [array get arg_error_CLR_nocolour - } - info { - variable arg_error_CLR_info - array set CLR [array get arg_error_CLR_info] - } - error { - variable arg_error_CLR_error - array set CLR [array get arg_error_CLR_error] - } - na { - } - } - - - #set RST [a] - set RST "\x1b\[m" - set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. - - #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error - #e.g list_as_table - - # use basic colours here to support terminals without extended colours - #todo - add checks column (e.g -minsize -maxsize) - set errmsg $msg - if {![catch {package require textblock}]} { - set has_textblock 1 - } else { - set has_textblock 0 - #couldn't load textblock package - #just return the original errmsg without formatting - } - set use_table 0 - if {$has_textblock && $returntype in {table tableobject}} { - set use_table 1 - } - set errlines [list] ;#for non-textblock output - if {[catch { - if {$use_table} { - append errmsg \n - } else { - if {($returntype in {table tableobject}) && !$has_textblock} { - append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n - } else { - append errmsg \n - } - } - set cmdname [Dict_getdef $spec_dict cmd_info -name ""] - set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] - - set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] - set docurl [Dict_getdef $spec_dict doc_info -url ""] - - #set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] - #set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] - #if {"$argdisplay_header$argdisplay_body" eq ""} { - # set is_custom_argdisplay 0 - #} else { - # set is_custom_argdisplay 1 - #} - - #temp - TODO - set argdisplay_header "" - set argdisplay_body "" - set is_custom_argdisplay 0 - - - set blank_header_col [list] - if {$cmdname ne ""} { - lappend blank_header_col "" - set cmdname_display $CLR(cmdname)$cmdname$RST - } else { - set cmdname_display "" - } - if {$cmdhelp ne ""} { - lappend blank_header_col "" - #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] - set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] - } else { - set cmdhelp_display "" - } - if {$docurl ne ""} { - lappend blank_header_col "" - set docurl_display [a+ white]$docurl$RST - } else { - set docurl_display "" - } - #synopsis - set synopsis "" - set form_info [dict get $spec_dict form_info] - dict for {fid finfo} $form_info { - set form_synopsis [Dict_getdef $finfo -synopsis ""] - if {$form_synopsis eq ""} { - #todo - set form_synopsis [punk::args::synopsis -form $fid [dict get $spec_dict id]] - if {[string length $form_synopsis] > 90} { - set form_synopsis [punk::args::synopsis -return summary -form $fid [dict get $spec_dict id]] - } - if {[string match (autodef)* $form_synopsis]} { - set form_synopsis [string range $form_synopsis 9 end] - } - } - if {$fid in $selected_forms} { - set form_synopsis [punk::ansi::a+ underline]$form_synopsis[punk::ansi::a+ nounderline] - } - append synopsis $form_synopsis \n - } - if {$synopsis ne ""} { - set synopsis [string trimright $synopsis \n] - lappend blank_header_col "" - } - - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - if {$use_table} { - set t [textblock::class::table new "$CLR(title)Usage$RST"] - $t add_column -headers $blank_header_col -minwidth 3 - $t add_column -headers $blank_header_col - - if {!$is_custom_argdisplay} { - lappend blank_header_col "" - #spanned columns in default argdisplay area - $t add_column -headers $blank_header_col ;#Default - $t add_column -headers $blank_header_col ;#Multi - $t add_column -headers $blank_header_col ;#Help - set arg_colspans {1 4 0 0 0} - } else { - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - set arg_colspans {1 1} - } - } - set h 0 - if {$cmdname ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] - } else { - lappend errlines "COMMAND: $cmdname_display" - } - incr h - } - if {$cmdhelp ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] - } else { - lappend errlines "Description: $cmdhelp_display" - } - incr h - } - if {$docurl ne ""} { - if {![catch {package require punk::ansi}]} { - set docurl [punk::ansi::hyperlink $docurl] - } - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] - } else { - lappend errlines "$docname $docurl_display" - } - incr h - } - if {$synopsis ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Synopsis: [punk::ansi::ansiwrap brightwhite $synopsis]] - } else { - #todo - lappend errlines "Synopsis:\n$synopsis" - } - incr h - } - - - if {$use_table} { - if {$is_custom_argdisplay} { - if {$argdisplay_header ne ""} { - $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] - } - } else { - $t configure_header $h -values {Arg Type Default Multi Help} - } - } else { - lappend errlines " --ARGUMENTS-- " - } - - if {$is_custom_argdisplay} { - if {$use_table} { - #using overall container table - #header already added - #TODO - review textblock::table features - #we can't currently span columns within the table body. - #This feature could allow hidden data columns (and sort on hidden col?) - #potentially require coordination with header colspans? - $t add_row [list "" $argdisplay_body] - } else { - if {$argdisplay_header ne ""} { - lappend errlines $argdisplay_header - } - lappend errlines {*}$argdisplay_body - } - } else { - - #set A_DEFAULT [a+ brightwhite Brightgreen] - set A_DEFAULT "" - set A_BADARG $CLR(badarg) - set A_GOODARG $CLR(goodarg) - set A_GOODCHOICE $CLR(goodchoice) - set greencheck $CLR(check)\u2713$RST ;#green tick - set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply - if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { - #A_PREFIX can resolve to empty string if colour off - #we then want to display underline instead - set A_PREFIX [a+ underline] - set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space - } else { - set A_PREFIXEND $RST - } - - #TODO - foreach fid - set fid [lindex $selected_forms 0] - set form_dict [dict get $spec_dict FORMS $fid] - - set opt_names [list] - set opt_names_display [list] - set lookup_optset [dict create] - if {[llength [dict get $form_dict OPT_NAMES]]} { - set all_opts [list] - foreach optset [dict get $form_dict OPT_NAMES] { - set optmembers [split $optset |] - lappend all_opts {*}$optmembers - foreach o $optmembers { - dict set lookup_optset $o $optset - #goodargs - } - } - set full_goodargs [list] - #goodargs may have simplified entries for received opts of form -alias1|-alias2|-realname - #map -realname to full argname - foreach g $goodargs { - if {[string match -* $g] && [dict exists $lookup_optset $g]} { - lappend full_goodargs [dict get $lookup_optset $g] - } else { - lappend full_goodargs $g - } - } - set goodargs $full_goodargs - if {![catch {package require punk::trie}]} { - #todo - reservelist for future options - or just to affect the prefix calculation - # (similar to -choiceprefixreservelist) - - set trie [punk::trie::trieclass new {*}$all_opts --] - set idents [dict get [$trie shortest_idents ""] scanned] - #todo - check opt_prefixdeny - - $trie destroy - foreach optset [dict get $form_dict OPT_NAMES] { - set arginfo [dict get $form_dict ARG_INFO $optset] - if {[dict get $arginfo -prefix]} { - set opt_members [split $optset |] - set odisplay [list] - foreach opt $opt_members { - set id [dict get $idents $opt] - #REVIEW - if {$id eq $opt} { - set prefix $opt - set tail "" - } else { - set idlen [string length $id] - set prefix [string range $opt 0 $idlen-1] - set tail [string range $opt $idlen end] - } - lappend odisplay $A_PREFIX$prefix$A_PREFIXEND$tail - } - #lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail - lappend opt_names_display [join $odisplay |] - } else { - lappend opt_names_display $optset - } - #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] - lappend opt_names $optset - } - } else { - set opt_names [dict get $form_dict OPT_NAMES] - set opt_names_display $opt_names - } - } - set leading_val_names [dict get $form_dict LEADER_NAMES] - set trailing_val_names [dict get $form_dict VAL_NAMES] - - #dict for {argname info} [tcl::dict::get $form_dict arg_info] { - # if {![string match -* $argname]} { - # lappend leading_val_names [lpop trailing_val_names 0] - # } else { - # break - # } - #} - #if {![llength $leading_val_names] && ![llength $opt_names]} { - # #all vals were actually trailing - no opts - # set trailing_val_names $leading_val_names - # set leading_val_names {} - #} - set leading_val_names_display $leading_val_names - set trailing_val_names_display $trailing_val_names - #puts "--> parsedargs: $parsedargs" - set parsed_leaders [Dict_getdef $parsedargs leaders {}] - set parsed_opts [Dict_getdef $parsedargs opts {}] - set parsed_values [Dict_getdef $parsedargs values {}] - - #display options first then values - foreach argumentclassinfo [list [list leaders $leading_val_names_display $leading_val_names $parsed_leaders] [list opts $opt_names_display $opt_names $parsed_opts] [list values $trailing_val_names_display $trailing_val_names $parsed_values]] { - lassign $argumentclassinfo argumentclass argnames_display argnames parsedvalues - - foreach argshow $argnames_display arg $argnames { - set arginfo [dict get $form_dict ARG_INFO $arg] - if {[dict exists $arginfo -default]} { - set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" - } else { - set default "" - } - set help [Dict_getdef $arginfo -help ""] - set allchoices_originalcase [list] - set choices [Dict_getdef $arginfo -choices {}] - set choicegroups [Dict_getdef $arginfo -choicegroups {}] - set choicemultiple [dict get $arginfo -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] - set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] - set choiceprefixreservelist [Dict_getdef $arginfo -choiceprefixreservelist {}] ;#names used to calc prefix - but not available as actual choice. - if {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - set is_multiple 1 - } else { - set multiple "" - set is_multiple 0 - } - if {[dict exists $choicegroups ""]} { - dict lappend choicegroups "" {*}$choices - } else { - set choicegroups [dict merge [dict create "" $choices] $choicegroups] - } - #review - does choiceprefixdenylist need to be added? - dict for {groupname clist} $choicegroups { - lappend allchoices_originalcase {*}$clist - } - set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] - - if {$has_choices} { - if {$help ne ""} {append help \n} - if {[dict get $arginfo -nocase]} { - set casemsg " (case insensitive)" - set allchoices_prefixcalc [list {*}[string tolower $allchoices_originalcase] {*}$choiceprefixreservelist] - } else { - set casemsg " (case sensitive)" - set allchoices_prefixcalc [list {*}$allchoices_originalcase {*}$choiceprefixreservelist] - } - if {[dict get $arginfo -choiceprefix]} { - set prefixmsg " (choice prefix allowed)" - } else { - set prefixmsg "" - } - set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] - set choiceinfodict [Dict_getdef $arginfo -choiceinfo {}] - set formattedchoices [dict create] ;#use dict rather than array to preserve order - append help " Choices$prefixmsg$casemsg" - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - if {$choicemultiple_max == -1} { - append help \n " The value can be a list of $choicemultiple_min or more of these choices" - } else { - if {$choicemultiple_min eq $choicemultiple_max} { - append help \n " The value must be a list of $choicemultiple_min of these choices" - } else { - append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" - } - } - } - if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c [join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } else { - #set formattedchoices $choicegroups - #set formattedchoices [dict get $arginfo -choices] - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c [join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } - } else { - if {[catch { - set trie [punk::trie::trieclass new {*}$allchoices_prefixcalc] - set idents [dict get [$trie shortest_idents ""] scanned] - if {[dict get $arginfo -nocase]} { - #idents were calculated on lcase - remap keys in idents to original casing - set actual_idents $idents - foreach ch $allchoices_originalcase { - if {![dict exists $idents $ch]} { - #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting - #The actual testing is done in get_dict - dict set actual_idents $ch [dict get $idents [string tolower $ch]] - } - } - set idents $actual_idents - #puts "-----" - #puts "idents $idents" - } - - $trie destroy - dict for {groupname clist} $choicegroups { - foreach c $clist { - if {$c in $choiceprefixdenylist} { - set shortestid $c - } else { - set shortestid [dict get $idents $c] - } - if {$shortestid eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $shortestid] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set mk " [join $markers {}]" - } else { - set mk "" - } - set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]$mk" - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - #puts "-- parsed:$parsedvalues arg:$arg c:$c" - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } errM]} { - #this failure can happen if -nocase is true and there are ambiguous entries - #e.g -nocase 1 -choices {x X} - puts stderr "prefix marking failed\n$errM" - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c [join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } else { - #set formattedchoices $choicegroups - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c[join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } - - } - } - set choicetable_objects [list] - set choicetable_footers [dict create] - dict for {groupname formatted} $formattedchoices { - set numcols $choicecolumns ;#todo - dynamic? - if {[llength $formatted] < $numcols} { - #don't show blank cells if single line of results - set numcols [llength $formatted] - } - if {$numcols > 0} { - if {$use_table} { - #risk of recursing - #TODO -title directly in list_as_table - set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] - lappend choicetable_objects $choicetableobj - $choicetableobj configure -title $CLR(groupname)$groupname - #append help \n[textblock::join -- " " [$choicetableobj print]] - } else { - if {$groupname ne ""} { - append help \n \n "$CLR(groupname)Group: $groupname$RST" - } else { - append help \n - } - append help \n [join $formatted \n] - } - } else { - #we were given an empty set of choices. - #probably an error in the definition - but could happen if dynamically generated. - #(e.g ensemble where unknown mechanism is used for subcommands?) - #better to just display that there were none rather than totally break the usage output. - if {$usetable} { - #these will be displayed after all table entries - if {$groupname eq ""} { - dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" - } else { - dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" - } - } else { - if {$groupname eq ""} { - append help \n " " $CLR(errormsg)(no choices defined)$RST - } else { - append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST - } - } - } - } - set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width - foreach obj $choicetable_objects { - dict lappend twidths_by_colcount [$obj column_count] [$obj width] - } - foreach obj $choicetable_objects { - set cols [$obj column_count] - set widths [dict get $twidths_by_colcount $cols] - set max [tcl::mathfunc::max {*}$widths] - $obj configure -minwidth $max ;#expand smaller ones - set i 0 - while {$i < $cols} { - #keep text aligned left on expanded tables - $obj configure_column $i -blockalign left - incr i - } - - append help \n[textblock::join -- " " [$obj print]] - #set ansititle [dict get [$obj configure -title] value] - $obj destroy - } - if {[dict size $choicetable_footers]} { - foreach groupname [dict keys $formattedchoices] { - if {[dict exists $choicetable_footers $groupname]} { - append help \n [dict get $choicetable_footers $groupname] - } - } - } - - #review. use -type to restrict additional choices - may be different to values in the -choices - if {![dict get $arginfo -choicerestricted]} { - #when -choicemultiple - the -type refers to each selection - if {[dict get $arginfo -type] eq "string"} { - append help "\n (values not in defined choices are allowed)" - } else { - append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" - } - } - } - if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { - if {$is_multiple} { - set argshow "?${argshow}...?" - } else { - set argshow "?${argshow}?" - } - } else { - if {$is_multiple} { - set argshow "${argshow}..." - } - } - set typeshow [dict get $arginfo -type] - if {$typeshow eq "none"} { - set typeshow "$typeshow $soloflag" - } - if {[dict exists $arginfo -minsize]} { - append typeshow \n "-minsize [dict get $arginfo -minsize]" - } - if {[dict exists $arginfo -maxsize]} { - append typeshow \n "-maxsize [dict get $arginfo -maxsize]" - } - if {[dict exists $arginfo -range]} { - append typeshow \n "-range [dict get $arginfo -range]" - } - - if {$use_table} { - $t add_row [list $argshow $typeshow $default $multiple $help] - if {$arg eq $badarg} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG - } elseif {$arg in $goodargs} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $A_GOODARG - } - } else { - #review - formatting will be all over the shop due to newlines in typesshow, help - set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" - if {$arg eq $badarg} { - set arghelp [punk::ansi::ansiwrap -rawansi $A_BADARG $arghelp] - } elseif {$arg in $goodargs} { - set arghelp [punk::ansi::ansiwrap -rawansi $A_GOODARG $arghelp] - } - foreach ln [split $help \n] { - append arghelp " $ln" \n - } - lappend errlines $arghelp - } - } - - # ------------------------------------------------------------------------------------------------------- - # if the argument class can accept unnamed arguments (or if opts accepts unspecified flags) - display an indication - # ------------------------------------------------------------------------------------------------------- - switch -- $argumentclass { - leaders - values { - if {$argumentclass eq "leaders"} { - set class_unnamed LEADER_UNNAMED - set class_max LEADER_MAX - set class_required LEADER_REQUIRED - set class_directive_defaults LEADERSPEC_DEFAULTS - } else { - set class_unnamed VAL_UNNAMED - set class_max VAL_MAX - set class_required VAL_REQUIRED - set class_directive_defaults VALSPEC_DEFAULTS - } - if {[dict get $form_dict $class_unnamed]} { - set valmax [dict get $form_dict $class_max] - #set valmin [dict get $form_dict VAL_MIN] - if {$valmax eq ""} { - set valmax -1 - } - if {$valmax == -1} { - set possible_unnamed -1 - } else { - set possible_unnamed [expr {$valmax - [llength [dict get $form_dict $class_required]]}] - if {$possible_unnamed < 0} { - set possible_unnamed 0 - } - } - if {$possible_unnamed == -1 || $possible_unnamed > 0} { - #Note 'multiple' is always empty here as each unnamed is assigned to its own positional index - if {$possible_unnamed == 1} { - set argshow ?? - } else { - set argshow ?...? - } - set tp [dict get $form_dict $class_directive_defaults -type] - if {[dict exists $form_dict $class_directive_defaults -default]} { - set default [dict get $form_dict $class_directive_defaults -default] - } else { - set default "" - } - if {$use_table} { - $t add_row [list "$argshow" $tp $default "" ""] - } else { - set arghelp "[a+ bold]$argshow$RST TYPE:$tp DEFAULT:$default\n" - lappend errlines $arghelp - } - } - } - } - opts { - #display row to indicate if -any|-arbitrary true - - #review OPTSPEC_DEFAULTS -multiple ? - if {[dict get $form_dict OPT_ANY]} { - set argshow "?...?" - set tp [dict get $form_dict OPTSPEC_DEFAULTS -type] - if {[dict exists $form_dict OPTSPEC_DEFAULTS -default]} { - set default [dict get $form_dict OPTSPEC_DEFAULTS -default] - } else { - set default "" - } - if {$use_table} { - $t add_row [list "$argshow" $tp $default "" ""] - } else { - set arghelp "[a+ bold]$argshow$RST TYPE:$tp DEFAULT:$default\n" - lappend errlines $arghelp - } - } - } - } - - } ;#end foreach argumentclass - } ;#end is_custom_argdisplay - - if {$use_table} { - $t configure -show_hseps 0\ - -show_header 1\ - -ansibase_body $CLR(ansibase_body)\ - -ansibase_header $CLR(ansibase_header)\ - -ansiborder_header $CLR(ansiborder)\ - -ansiborder_body $CLR(ansiborder) - - $t configure -maxwidth 80 ;#review - if {$returntype ne "tableobject"} { - append errmsg [$t print] - #returntype of table means just the text of the table - $t destroy - } - } else { - append errmsg [join $errlines \n] - } - } errM]} { - append errmsg \n - append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n - append errmsg "$errM" \n - append errmsg "$::errorInfo" - catch {$t destroy} - - } - set arg_error_isrunning 0 - if {$use_table} { - #assert returntype is one of table, tableobject - set result $errmsg ;#default if for some reason table couldn't be used - if {$returntype eq "tableobject"} { - if {[info object isa object $t]} { - set result $t - } - } - } else { - set result $errmsg - } - if {$as_error} { - #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. - #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) - uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] - } else { - return $result - } - } - - - lappend PUNKARGS [list { - @dynamic - @id -id ::punk::args::usage - @cmd -name punk::args::usage -help\ - "Return usage information for a command identified by an id. - - This will only work for commands where a punk::args definition exists - for the command and an id has been defined for it. The id for custom - help for a command should match the fully qualified name of the command. - - Many commands (such as ensembles and oo objects) may have argument - documentation generated dynamically and may not yet have an id. - IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. - - Generally punk::ns::arginfo (aliased as i in the punk shell) should - be used in preference - as it will search for a documentation - mechanism and call punk::args::usage as necessary. - " - -return -default table -choices {string table tableobject} - }\ - {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}}\ - {${[punk::args::resolved_def -types opts ::punk::args::resolved_def -form]}}\ - { - - @values -min 0 -max 1 - id -help\ - "Exact id. - Will usually match the command name" - }] - proc usage {args} { - #lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received - lassign [dict values [punk::args::parse $args withid ::punk::args::usage]] leaders opts values received - set id [dict get $values id] - set real_id [real_id $id] - if {$real_id eq ""} { - error "punk::args::usage - no such id: $id" - } - #-scheme punk_info ?? - arg_error "" [punk::args::get_spec $real_id] {*}$opts -aserror 0 - } - - lappend PUNKARGS [list { - @id -id ::punk::args::get_by_id - @cmd -name punk::args::get_by_id - @values -min 1 - id - arglist -type list -help\ - "list containing arguments to be parsed as per the - argument specification identified by the supplied id." - }] - - - #deprecate? - proc get_by_id {id arglist} { - set definitionlist [punk::args::raw_def $id] - if {[llength $definitionlist] == 0} { - error "punk::args::get_by_id - no such id: $id" - } - #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] - tailcall ::punk::args::get_dict $definitionlist $arglist - } - - #consider - - #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) - #parse ?-flag val?... -- $arglist withid $id - #parse ?-flag val?... -- $arglist withdef $def ?$def?... - - #an experiment.. ideally we'd like arglist at the end? - #parse_withid ?-flag val?.. $id $arglist - #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? - #no possible equivalent for parse_withdef ??? - - lappend PUNKARGS [list { - @id -id ::punk::args::parse - @cmd -name punk::args::parse -help\ - "parse and validate command arguments based on a definition. - - In the 'withid' form the definition is a pre-existing record that has been - created with ::punk::args::define, or indirectly by adding a definition to - the PUNKARGS variable in a namespace which is then registered in - punk::args::register::NAMESPACES, or by a previous call to punk::parse - using 'withdef' and a definition block containing an @id -id directive. - - In the 'withdef' form - the definition is created on the first call and - cached thereafter, if the id didn't already exist. - - form1: parse $arglist ?-flag val?... withid $id - form2: parse $arglist ?-flag val?... withdef $def ?$def? - see punk::args::define - - Returns a dict of information regarding the parsed arguments - example of basic usage for single option only: - punk::args::define { - @id -id ::myns::myfunc - @cmd -name myns::myfunc - @leaders -min 0 -max 0 - @opts - -configfile -type existingfile - #type none makes it a solo flag - -verbose -type none - @values -min 0 -max 0 - } - proc myfunc {args} { - set argd [punk::args::parse $args withid ::myns::myfunc] - lassign [dict values $argd] leaders opts values received solos - if {[dict exists $received] -configfile} { - puts \"have option for existing file [dict get $opts -configfile]\" - } - } - The leaders, opts, values keys in the parse result dict are proper dicts. - The received key is dict-like but can have repeated keys for arguments than can - accept multiples. The value for each received element is the ordinal position. - The solos key refers to a list of solo flags received (those specified with - -type none). This is generally only useful to assist in passing arguments on - to another procedure which also requires solos, because the opts dict contains - solo flags with a 1 value or a list of 1's if it was a solo with -multiple true - specified. - " - @form -form {withid withdef} - @leaders -min 1 -max 1 - arglist -type list -optional 0 -help\ - "Arguments to parse - supplied as a single list" - - @opts - -form -type list -default * -help\ - "Restrict parsing to the set of forms listed. - Forms are the orthogonal sets of arguments a - command can take - usually described in 'synopsis' - entries." - #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance - #todo - configurable per interp/namespace - -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} - - @values -min 2 - - @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" - @values -max 2 - withid -type literal -help\ - "The literal value 'withid'" - id -type string -help\ - "id of punk::args definition for a command" - - - @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" - withdef -type literal -help\ - "The literal value 'withdef'" - - #todo - make -dynamic obsolete - use @dynamic directive instead - def -type string -multiple 1 -optional 0 -help\ - "Each remaining argument is a block of text - defining argument definitions. - As a special case, -dynamic may be - specified as the 1st 2 arguments. These are - treated as an indicator to punk::args about - how to process the definition." - - }] - proc parse {args} { - #puts "punk::args::parse --> '$args'" - set tailtype "" ;#withid|withdef - if {[llength $args] < 3} { - #error "punk::args::parse - invalid call. < 3 args" - punk::args::parse $args withid ::punk::args::parse - } - set opts_and_vals $args - set parseargs [lpop opts_and_vals 0] - - set opts [list] - set values [list] - for {set i 0} {$i < [llength $opts_and_vals]} {incr i} { - if {[string match -* [lindex $opts_and_vals $i]]} { - if {[catch { - lappend opts [lpop opts_and_vals 0] [lpop opts_and_vals 0] - }]} { - #unhappy path - not enough options - #review - which form of punk::args::parse? - punk::args::parse $args withid ::punk::args::parse - } - incr i -1 - #lappend opts $a [lindex $opts_and_vals $i] - } else { - break - } - } - #set values [lrange $opts_and_vals $i end] - set values $opts_and_vals - #puts "---values: $values" - set tailtype [lindex $values 0] - set tailargs [lrange $values 1 end] - - - #set split [lsearch -exact $tailargs withid] - #if {$split < 0} { - # set split [lsearch -exact $tailargs withdef] - # if {$split < 0} { - # #punk::args::usage arg_error? - # #error "punk::args::parse - invalid call. keyword withid|withdef required" - # punk::args::parse $args withid ::punk::args::parse - # } else { - # set tailtype withdef - #} - #} else { - # set tailtype withid - #} - #set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. - - - #if {[llength $opts] % 2} { - #error "punk::args::parse Even number of -flag val pairs required after arglist" - #} - - #Default the -errorstyle to enhanced - # (slowest on unhappy path - but probably clearest for playing with new APIs interactively) - # - application devs should distribute a config file with an errorstyle override if desired. - # - devs who prefer a different default for interactive use should create a config for it. (todo) - set defaultopts [dict create\ - -form {*}\ - -errorstyle enhanced\ - ] - - #todo - load override_errorstyle from configuration - #dict set defaultopts -errorstyle $ - #puts "def: $defaultopts opts: $opts" - set opts [dict merge $defaultopts $opts] - dict for {k v} $opts { - switch -- $k { - -form - -errorstyle { - } - default { - #punk::args::usage $args withid ::punk::args::parse ?? - #error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" - punk::args::parse $args withid ::punk::args::parse - } - } - } - switch -- $tailtype { - withid { - if {[llength $tailargs] != 1} { - #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - punk::args::parse $args withid ::punk::args::parse - } - set id [lindex $tailargs 0] - #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" - #puts stdout "punk::args::parse '$parseargs' withid $id, options: $opts" - set deflist [raw_def $id] - if {[llength $deflist] == 0} { - error "punk::args::parse - no such id: $id" - } - } - withdef { - set deflist $tailargs - if {[llength $deflist] < 1} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" - #puts stdout "punk::args::parse '$parseargs' with [llength $deflist] definition blocks, options: $opts" - } - default { - error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" - } - } - try { - #puts stdout "parse --> get_dict $parseargs -form [dict get $opts -form]" - set result [punk::args::get_dict $deflist $parseargs -form [dict get $opts -form]] - } trap {PUNKARGS VALIDATION} {msg erroropts} { - set opt_errorstyle [dict get $opts -errorstyle] - - #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - - - set ecode [dict get $erroropts -errorcode] - #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... - set msg [string map [list %caller% [Get_caller]] $msg] - switch -- $opt_errorstyle { - minimal { - return -options [list -code error -errorcode $ecode] $msg - } - basic { - #No table layout - unix manpage style - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg -form [dict get $opts -form]] - } - return -options [list -code error -errorcode $ecode] $msg - } - standard { - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] - } - return -options [list -code error -errorcode $ecode] $msg - } - enhanced { - set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below) - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - set ecode_summary [lrange $ecode 0 2] - if {$badarg ne ""} { - lappend ecode_summary -badarg $badarg - } - catch {package require punk::lib} - if {[package provide punk::lib] ne ""} { - append msg \n [punk::lib::showdict -roottype list $estack */*] - } - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] - append msg \n "::errorCode summary: $ecode_summary" - return -options [list -code error -errorcode $ecode] $msg - } else { - #why? todo? - append msg \n "(enhanced error information unavailable)" - append msg \n "::errorCode summary: $ecode_summary" - return -options [list -code error -errorcode $ecode] $msg - } - } - debug { - puts stderr "errorstyle debug not implemented" - return -options [list -code error -errorcode $ecode] $msg - } - default { - puts stderr "errorstyle $opt_errorstyle not recognised: expected one of minimal basic standard enhanced debug" - return -options [list -code error -errorcode $ecode] $msg - } - } - } trap {PUNKARGS} {msg erropts} { - append msg \n "Unexpected PUNKARGS error" - return -options [list -code error -errorcode $ecode] $msg - } trap {} {msg erroropts} { - #review - #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. - #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. - throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] - } - return $result - } - proc parseXXX {args} { - #no solo flags allowed for parse function itself. (ok for arglist being parsed) - set opts [dict create] ;#repeated flags will override earlier. That's ok here. - set arglist {} - set got_arglist 0 - set tailtype "" ;#withid|withdef - set id "" - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {[string match -* $a]} { - dict set opts $a [lindex $args $i+1] - incr i - } else { - set arglist $a - set got_arglist 1 - set tailtype [lindex $args $i+1] - if {$tailtype eq "withid"} { - if {[llength $args] != $i+3} { - error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - } - set id [lindex $args $i+2] - break - } elseif {$tailtype eq "withdef"} { - if {[llength $args] < $i+3} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - set deflist [lrange $args $i+2 end] - break - } else { - error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" - } - } - } - if {!$got_arglist} { - error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." - } - #assert tailtype eq withid|withdef - if {$tailtype eq "withid"} { - #assert $id was provided - return "parse [llength $arglist] args withid $id, options:$opts" - } else { - #assert llength deflist >=1 - return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" - } - #TODO - } - - - #return number of values we can assign to cater for variable length clauses such as {"elseif" expr "?then?" body} - #review - efficiency? each time we call this - we are looking ahead at the same info - proc _get_dict_can_assign_value {idx values nameidx names namesreceived formdict} { - set ARG_INFO [dict get $formdict ARG_INFO] - set all_remaining [lrange $values $idx end] - set thisname [lindex $names $nameidx] - set thistype [dict get $ARG_INFO $thisname -type] - set tailnames [lrange $names $nameidx+1 end] - - #todo - work backwards with any (optional or not) literals at tail that match our values - and remove from assignability. - set ridx 0 - foreach clausename [lreverse $tailnames] { - #puts "=============== clausename:$clausename all_remaining: $all_remaining" - set typelist [dict get $ARG_INFO $clausename -type] - if {[lsearch $typelist literal*] == -1} { - break - } - set max_clause_length [llength $typelist] - if {$max_clause_length == 1} { - #basic case - set alloc_ok 0 - #set v [lindex $values end-$ridx] - set v [lindex $all_remaining end] - set tp [lindex $typelist 0] - #review - ignore ?literal? and ?literal(xxx)? when clause-length == 1? (should raise error during definition instead? - #we shouldn't have an optional clause member if there is only one member - the whole name should be marked -optional true instead. - set tp [string trim $tp ?] - if {[string match literal* $tp]} { - set litinfo [string range $tp 7 end] ;#get bracketed part if of form literal(xxx) - if {[string match (*) $litinfo]} { - set match [string range $litinfo 1 end-1] - } else { - #plain "literal" without bracketed specifier - match to argument name - set match $clausename - } - if {$v eq $match} { - set alloc_ok 1 - lpop all_remaining - if {![dict get $ARG_INFO $clausename -multiple]} { - lpop tailnames - } - } else { - #break - } - } else { - #break - } - if {!$alloc_ok} { - if {![dict get $ARG_INFO $clausename -optional]} { - break - } - } - } else { - #review - we assume here that we don't have a set of clause-members where all are marked optional (?membertype?) - #This is better caught during definition. - #e.g rn = {elseif expr (?then?) body} typelist = {literal expr ?literal? script} - #set cvals [lrange $values end-$ridx end-[expr {$ridx + $max_clause_length-1}]] - set cvals [lrange $values end-[expr {$ridx + $max_clause_length-1}] end-$ridx] - set rcvals [lreverse $cvals] - set alloc_count 0 - #clause name may have more entries than types - extras at beginning are ignored - set rtypelist [lreverse $typelist] - set rclausename [lrange [lreverse $clausename] 0 [llength $typelist]-1] - #assert length of rtypelist >= $rclausename - set alloc_ok 0 - set reverse_type_index 0 - foreach tp $rtypelist membername $rclausename { - #(membername may be empty if not enough elements) - #set rv [lindex $rcvals end-$alloc_count] - set rv [lindex $all_remaining end-$alloc_count] - if {[string match {\?*\?} $tp]} { - set clause_member_optional 1 - } else { - set clause_member_optional 0 - } - set tp [string trim $tp ?] - if {[string match literal* $tp]} { - set litinfo [string range $tp 7 end] - if {[string match (*) $litinfo]} { - set match [string range $litinfo 1 end-1] - } else { - #if membername empty - equivalent to "literal()" - matches empty string literal - #edgecase - possibly? no need for empty-string literals - but allow it without error. - set match $membername - } - if {$rv eq $match} { - set alloc_ok 1 ;#we need at least one literal-match to set alloc_ok - incr alloc_count - } else { - if {$clause_member_optional} { - # - } else { - set alloc_ok 0 - break - } - } - } else { - if {$clause_member_optional} { - #review - optional non-literal makes things harder.. - #we don't want to do full type checking here - but we now risk allocating an item that should actually - #be allocated to the previous value - set prev_type [lindex $rtypelist $reverse_type_index+1] - if {[string match literal* $prev_type]} { - set litinfo [string range $prev_type 7 end] - if {[string match (*) $litinfo]} { - set match [string range $litinfo 1 end-1] - } else { - #prev membername - set match [lindex $rclausename $reverse_type_index+1] - } - if {$rv ne $match} { - #current val doesn't match previous type - allocate here - incr alloc_count - } - } else { - #no literal to anchor against.. - incr alloc_count - } - } else { - #allocate regardless of type - we're only matching on arity and literal positioning here. - #leave final type-checking for later. - incr alloc_count - } - } - incr reverse_type_index - } - if {$alloc_ok && $alloc_count > 0} { - #set n [expr {$alloc_count -1}] - #set all_remaining [lrange $all_remaining end-$n end] - set all_remaining [lrange $all_remaining 0 end-$alloc_count] - #don't lpop if -multiple true - if {![dict get $ARG_INFO $clausename -multiple]} { - lpop tailnames - } - } else { - break - } - } - incr ridx - } - set num_remaining [llength $all_remaining] - - if {[dict get $ARG_INFO $thisname -optional] || ([dict get $ARG_INFO $thisname -multiple] && $thisname in $namesreceived)} { - #todo - check -multiple for required min/max (not implemented: make -multiple accept ?) - #thisname already satisfied, or not required - set tail_needs 0 - foreach t $tailnames { - if {![dict get $ARG_INFO $t -optional]} { - set min_clause_length [llength [lsearch -all -not [dict get $ARG_INFO $t -type] {\?*\?}]] - incr tail_needs $min_clause_length - } - } - set all_remaining [lrange $all_remaining 0 end-$tail_needs] - } - - #thistype - set alloc_ok 1 - set alloc_count 0 - set resultlist [list] - set n [expr {[llength $thistype]-1}] - #name can have more or less items than typelist - set thisnametail [lrange $thisname end-$n end] - foreach tp $thistype membername $thisnametail { - set v [lindex $all_remaining $alloc_count] - if {[string match {\?*\?} $tp]} { - set clause_member_optional 1 - } else { - set clause_member_optional 0 - } - set tp [string trim $tp ?] - if {[string match literal* $tp]} { - set litinfo [string range $tp 7 end] - if {[string match (*) $litinfo]} { - set match [string range $litinfo 1 end-1] - } else { - set match $membername - } - if {$v eq $match} { - if {$clause_member_optional && $alloc_count >= [llength $all_remaining]} { - lappend resultlist "" - } else { - lappend resultlist $v - incr alloc_count - } - } else { - if {$clause_member_optional} { - #todo - configurable default for optional clause members? - lappend resultlist "" - } else { - set alloc_ok 0 - break - } - } - } else { - if {$clause_member_optional} { - if {$alloc_count >= [llength $all_remaining]} { - lappend resultlist "" - } else { - lappend resultlist $v - incr alloc_count - } - } else { - lappend resultlist $v - incr alloc_count - } - } - if {$alloc_count > [llength $all_remaining]} { - set alloc_ok 0 - break - } - } - if {$alloc_ok} { - set d [dict create consumed $alloc_count resultlist $resultlist] - } else { - set d [dict create consumed 0 resultlist {}] - } - #puts ">>>> _get_dict_can_assign_value $d" - return $d - } - - #todo? - a version of get_dict that directly supports punk::lib::tstr templating - #rename get_dict - # - - #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 get_dict {deflist rawargs args} { - #see arg_error regarding considerations around unhappy-path performance - - if {[llength $args] % 2 != 0} { - error "punk::args::get_dict args must be a dict of option value pairs" - } - set defaults [dict create\ - -form *\ - ] - set opts [dict merge $defaults $args] - dict for {k v} $opts { - switch -- $k { - -form {} - default { - error "punk::args::get_dict Unexpected option '$k' Known options -form" - } - } - } - - - #*** !doctools - #[call [fun get_dict] [arg deflist] [arg rawargs] [arg args]] - #[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 values - #[para]ARGUMENTS: - #[list_begin arguments] - #[arg_def list-of-multiline-string deflist] - #[para] These are blocks 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 defining a flag 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 - #[para]Each optionspec line defining a positional argument is of the form: - #[para]argumentname -key val -ky2 val2... - #[para]where the valid keys for each option specification are: -default -type -range -choices - #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value - #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. - #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. - #[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, - #but it could be a manually constructed list of values made for example from positional args defined in the proc. - #[list_end] - #[para] - - #consider line-processing example below for which we need info complete to determine record boundaries - #punk::args::get_dict [list { - # @opts - # -opt1 -default {} - # -opt2 -default { - # etc - # } - # @values -multiple 1 - #}] $args - - - - - #rawargs: args values to be parsed - #we take a definition list rather than resolved argspecs - because the definition could be dynamic - - #if definition has been seen before, - #define will either return a permanently cached argspecs (-dynamic 0) - or - # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. - set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]] - - # ----------------------------------------------- - # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) - tcl::dict::with argspecs {} ;#turn keys into vars - #e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info,id_info,form_names - # ----------------------------------------------- - set opt_form [dict get $opts -form] - if {$opt_form eq "*"} { - set selected_forms $form_names - } elseif {[string is integer -strict $opt_form]} { - if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { - error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set selected_forms [list [lindex $form_names $opt_form]] - } else { - if {$opt_form ni $form_names} { - error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set selected_forms [list $opt_form] - } - - - #puts "-arg_info->$arg_info" - set flagsreceived [list] ;#for checking if required flags satisfied - set solosreceived [list] - set multisreceived [list] - #secondary purpose: - #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 ? - - # -- --- --- --- - # Handle leading positionals - # todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ? - - #todo - handle multiple fids? - set fid [lindex $selected_forms 0] - set formdict [dict get $FORMS $fid] - tcl::dict::with formdict {} - #populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc - if {$VAL_MIN eq ""} { - set valmin 0 - #set VAL_MIN 0 - foreach v $VAL_NAMES { - if {![dict get $ARG_INFO $v -optional]} { - # todo variable clause lengths (items marked optional in types using leading&trailing questionmarks) - # e.g -types {a ?xxx?} - #this has one required and one optional - set typelist [dict get $ARG_INFO $v -type] - set clause_length 0 - foreach t $typelist { - if {![string match {\?*\?} $t]} { - incr clause_length - } - } - incr valmin $clause_length - } - } - } else { - set valmin $VAL_MIN - } - - set pre_values {} - - set argnames [tcl::dict::keys $ARG_INFO] - #set optnames [lsearch -all -inline $argnames -*] - #JJJ - set all_opts [list] - set lookup_optset [dict create] - foreach optset $OPT_NAMES { - set optmembers [split $optset |] - lappend all_opts {*}$optmembers - foreach opt $optmembers { - dict set lookup_optset $opt $optset - } - } - set ridx 0 - set rawargs_copy $rawargs - set remaining_rawargs $rawargs - set leader_posn_name "" - set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) - set is_multiple 0 ;#last leader may be multi - #consider for example: LEADER_NAMES {"k v" "a b c" x} - #(i.e clause-length of 2 3 and 1) - #This will take 6 raw leaders to fill in the basic case that all are -optional 0 and -multiple 0 - set named_leader_args_max 0 - foreach ln $LEADER_NAMES { - incr named_leader_args_max [llength $ln] - } - - #set id [dict get $argspecs id] - #if {$id eq "::if"} { - #puts stderr "::if" - #puts stderr "get_dict--> remaining_rawargs: $remaining_rawargs" - #} - set nameidx 0 - if {$LEADER_MAX != 0} { - for {set ridx 0} {$ridx < [llength $rawargs]} {incr ridx} { - set r [lindex $rawargs $ridx] - if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { - break - } - if {[llength $LEADER_NAMES] && $nameidx == [llength $LEADER_NAMES]-1} { - #at last named leader - set leader_posn_name [lindex $LEADER_NAMES $nameidx] - if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { - set is_multiple 1 - } - } elseif {$ridx > $named_leader_args_max-1} { - #beyond names - retain name if -multiple was true - if {!$is_multiple} { - set leader_posn_name "" - } - } else { - set leader_posn_name [lindex $LEADER_NAMES $nameidx] ;#may return empty string - } - if {$OPT_MAX ne "0" && $r eq "--"} { - #review end of opts marker: '--' can't be a leader (but can be a value) - break - } - - #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option - if {$OPT_MAX ne "0" && [tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { - set matchopt [::tcl::prefix::match -error {} $all_opts $r] - if {$matchopt ne ""} { - #flaglike matches a known flag - don't treat as leader - break - } - if {$leader_posn_name ne ""} { - #false alarm - #there is a named leading positional for this position - #The flaglooking value doesn't match an option - so treat as a leader - incr ridx -1 - foreach v $leader_posn_name { - incr ridx - lappend pre_values [lpop remaining_rawargs 0] - } - if {!$is_multiple} { - incr nameidx - } - dict incr leader_posn_names_assigned $leader_posn_name - #incr ridx - continue - } else { - break - } - } - - #for each branch - break or lappend - if {$leader_posn_name ne ""} { - #todo - variable clauselengths e.g 'if' command which has optional 'then' and 'else' "noise words" - set clauselength [llength $leader_posn_name] - if {$leader_posn_name ni $LEADER_REQUIRED} { - #optional leader - - #most adhoc arg processing will allocate based on number of args rather than matching choice values first - #(because a choice value could be a legitimate data value) - - #review - option to process in this manner? - #first check if the optional leader value is a match for a choice ? - #if {[dict exists $arg_info $leader_posn_name -choices]} { - # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] [lindex $remaining_rawargs 0]] - # if {$vmatch ne ""} { - # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values - # lappend pre_values [lpop remaining_rawargs 0] - # incr ridx - # continue - # } - #} - if {[llength $remaining_rawargs] < $clauselength} { - #not enough remaining args to fill even this optional leader - #rather than raise error here - perform our break (for end of leaders) and let the code below handle it - break - } - - #check if enough remaining_rawargs to fill any required values - if {$valmin > 0 && [llength $remaining_rawargs] - $clauselength < $valmin} { - break - } - - #leadername may be a 'clause' of arbitrary length (e.g {"key val"} or {"key val etc"}) - incr ridx -1 - foreach v $leader_posn_name { - incr ridx - lappend pre_values [lpop remaining_rawargs 0] - } - if {!$is_multiple} { - incr nameidx - } - dict incr leader_posn_names_assigned $leader_posn_name - } else { - #required - if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { - #already accepted at least one value - requirement satisfied - now equivalent to optional - if {[llength $remaining_rawargs] < $clauselength} { - #not enough remaining args to fill even this optional leader - #rather than raise error here - perform our break (for end of leaders) and let the code below handle it - break - } - - if {$valmin > 0 && [llength $remaining_rawargs] - $clauselength < $valmin} { - break - } - } - #if we didn't break - requirement is not yet satisfied, or is satisfied but still enough remaining_rawargs for required values - #we still need to check if enough values for the leader itself - if {[llength $remaining_rawargs] < $clauselength} { - #not enough remaining args to fill *required* leader - break - } - - incr ridx -1 - foreach v $leader_posn_name { - incr ridx - lappend pre_values [lpop remaining_rawargs 0] - } - if {!$is_multiple} { - incr nameidx - } - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #unnamed leader - if {$LEADER_MIN ne "" } { - if {$ridx > $LEADER_MIN-1} { - if {$LEADER_MAX ne "" && $ridx == $LEADER_MAX} { - break - } else { - if {$valmin > 0} { - if {[llength $remaining_rawargs] > $valmin} { - lappend pre_values [lpop remaining_rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } else { - break - } - } else { - lappend pre_values [lpop remaining_rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } - } else { - #haven't reached LEADER_MIN - lappend pre_values [lpop remaining_rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #review - if is_multiple, keep going if enough remaining_rawargs for values? - break - } - } - - #incr ridx - } ;# end foreach r $rawargs_copy - } - - set argstate $ARG_INFO ;#argstate may have entries added - set arg_checks $ARG_CHECKS - - if {$LEADER_MIN eq ""} { - set leadermin 0 - } else { - set leadermin $LEADER_MIN - } - if {$LEADER_MAX eq ""} { - set leadermax -1 - } else { - set leadermax $LEADER_MAX - } - - if {$VAL_MAX eq ""} { - set valmax -1 - } else { - set valmax $VAL_MAX - } - - #assert leadermax leadermin are numeric - #assert - remaining_rawargs has been reduced by leading positionals - - set opts [dict create] ;#don't set to OPT_DEFAULTS here -#JJJ - #set id [dict get $argspecs id] - #if {$id eq "::if"} { - #puts stderr "::if" - #puts stderr "get_dict--> pre_values: $pre_values" - #puts stderr "get_dict--> remaining_rawargs: $remaining_rawargs" - #} - - set leaders [list] - set arglist {} - set post_values {} - #valmin, valmax - #puts stderr "remaining_rawargs: $remaining_rawargs" - #puts stderr "argstate: $argstate" - if {$OPT_MAX ne "0" && [lsearch $remaining_rawargs -*] >= 0} { - #at least contains flaglike things.. - set maxidx [expr {[llength $remaining_rawargs] -1}] - if {$valmax == -1} { - set vals_total_possible [llength $remaining_rawargs] - set vals_remaining_possible $vals_total_possible - } else { - set vals_total_possible $valmax - set vals_remaining_possible $vals_total_possible - } - for {set i 0} {$i <= $maxidx} {incr i} { - set a [lindex $remaining_rawargs $i] - set remaining_args_including_this [expr {[llength $remaining_rawargs] - $i}] - #lowest valmin is 0 - if {$remaining_args_including_this <= $valmin} { - # if current arg is -- it will pass through as a value here - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - break - } - - #exlude argument with whitespace from being a possible option e.g dict - if {[tcl::string::match -* $a] && !([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { - if {$a eq "--"} { - #remaining num args <= valmin already covered above - if {$valmax != -1} { - #finite max number of vals - if {$remaining_args_including_this == $valmax} { - #assume it's a value. - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - } else { - #assume it's an end-of-options marker - lappend flagsreceived -- - set arglist [lrange $remaining_rawargs 0 $i] - set post_values [lrange $remaining_rawargs $i+1 end] - } - } else { - #unlimited number of post_values accepted - #treat this as eopts - we don't care if remainder look like options or not - lappend flagsreceived -- - set arglist [lrange $remaining_rawargs 0 $i] - set post_values [lrange $remaining_rawargs $i+1 end] - } - break - } else { - set opt [tcl::prefix match -error "" [list {*}$all_opts --] $a] - if {$opt eq "--"} {set opt ""} - if {[dict exists $lookup_optset $opt]} { - set fullopt [dict get $lookup_optset $opt] - } else { - set fullopt "" - } - if {$fullopt ne ""} { - #e.g when fullopt eq -fg|-foreground - #-fg is an alias , -foreground is the 'api' value for the result dict - #$fullopt remains as the key in the spec - set optmembers [split $fullopt |] - set api_opt [lindex $optmembers end] - - if {![tcl::dict::get $argstate $fullopt -prefix] && $a ni $optmembers} { - #attempt to use a prefix when not allowed - #review - by ending opts here - we dont' get the clearest error msgs - # may *sometimes* be better to raise a PUNKARGS VALIDATION (invalidoption) error - # (but it may actually be the first value that just happens to be flaglike) - #todo - check for subsequent valid flags or -- marker? - #consider for example 'file delete -f -- old.txt' - #If we just end option-processing, the punk::args parser would pass {-f -- old.txt} as values - #whereas the builtin file arg parser alerts that -f is a bad option - set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $all_opts" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $all_opts] -badarg $a -argspecs $argspecs]] $errmsg - #set arglist [lrange $remaining_rawargs 0 $i-1] - #set post_values [lrange $remaining_rawargs $i end] - #break - } - if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { - #non-solo - #check if it was actually a value that looked like a flag - if {$i == $maxidx} { - #if no optvalue following - assume it's a value - #(caller should probably have used -- before it) - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - break - } - - set flagval [lindex $remaining_rawargs $i+1] - if {[tcl::dict::get $argstate $fullopt -multiple]} { - #don't lappend to default - we need to replace if there is a default - if {$api_opt ni $flagsreceived} { - tcl::dict::set opts $api_opt [list $flagval] - } else { - tcl::dict::lappend opts $api_opt $flagval - } - if {$api_opt ni $multisreceived} { - lappend multisreceived $api_opt - } - } else { - tcl::dict::set opts $api_opt $flagval - } - #incr i to skip flagval - incr vals_remaining_possible -2 - if {[incr i] > $maxidx} { - set msg "Bad options for %caller%. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $fullopt index [expr {$i-1}]] -badarg $fullopt -argspecs $argspecs]] $msg - } - } else { - #solo - if {[tcl::dict::get $argstate $fullopt -multiple]} { - if {$api_opt ni $flagsreceived} { - #override any default - don't lappend to it - tcl::dict::set opts $api_opt 1 - } else { - tcl::dict::lappend opts $api_opt 1 - } - if {$api_opt ni $multisreceived} { - lappend multisreceived $fullopt - } - } else { - tcl::dict::set opts $api_opt 1 - } - incr vals_remaining_possible -1 - lappend solosreceived $api_opt ;#dups ok - } - lappend flagsreceived $api_opt ;#dups ok - } else { - #unmatched option flag - #comparison to valmin already done above - if {$valmax ne -1 && $remaining_args_including_this <= $valmax} { - #todo - look at optspec_default and see if solo/vs opt-val pair - #we may need to lookahead by 2 regarding valmax valmin - - #even with optany - assume an unknown within the space of possible values is a value - #unmatched option in right position to be considered a value - treat like eopts - #review - document that an unspecified arg within range of possible values will act like eopts -- - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - break - } - if {$OPT_ANY} { - set newval [lindex $remaining_rawargs $i+1] - #opt was unspecified but is allowed due to @opts -any|-arbitrary true - 'adhoc/passthrough' option - tcl::dict::set argstate $a $OPTSPEC_DEFAULTS ;#use default settings for unspecified opt - tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS - if {[tcl::dict::get $argstate $a -type] ne "none"} { - if {[tcl::dict::get $argstate $a -multiple]} { - tcl::dict::lappend opts $a $newval - if {$a ni $multisreceived} { - lappend multisreceived $a - } - } else { - tcl::dict::set opts $a $newval - } - if {[incr i] > $maxidx} { - set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg - #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a - } - incr vals_remaining_possible -2 - } else { - #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none - if {[tcl::dict::get $argstate $a -multiple]} { - if {![tcl::dict::exists $opts $a]} { - tcl::dict::set opts $a 1 - } else { - tcl::dict::lappend opts $a 1 - } - if {$a ni $multisreceived} { - lappend multisreceived $a - } - } else { - tcl::dict::set opts $a 1 - } - incr vals_remaining_possible -1 - lappend solosreceived $a - } - lappend flagsreceived $a ;#adhoc flag as supplied - } else { - if {[llength $OPT_NAMES]} { - set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES" - } else { - set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any|-arbitrary false" - } - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg - #arg_error $errmsg $argspecs -badarg $fullopt - } - } - } - } else { - #not flaglike - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - break - } - } - #set values [list {*}$pre_values {*}$post_values] - set leaders $pre_values - set values $post_values - } else { - set leaders $pre_values - set values $remaining_rawargs - #set values [list {*}$pre_values {*}$remaining_rawargs] ;#no -flags detected - set arglist [list] - } - #set id [dict get $argspecs id] - #if {$id eq "::if"} { - #puts stderr "::if" - #puts stderr "get_dict--> arglist: $arglist" - #puts stderr "get_dict--> leaders: $leaders" - #puts stderr "get_dict--> values: $values" - #} - - #--------------------------------------- - set ordered_opts [dict create] - set unaliased_opts [lmap v $OPT_NAMES {lindex [split $v |] end}] - #unaliased_opts is list of 'api_opt' (handle aliases of form -a1|-a2|-api_opt e.g -fg|-foreground) - foreach o $unaliased_opts optset $OPT_NAMES { - if {[dict exists $opts $o]} { - dict set ordered_opts $o [dict get $opts $o] - } elseif {[dict exists $OPT_DEFAULTS $optset]} { - dict set ordered_opts $o [dict get $OPT_DEFAULTS $optset] - } - } - #add in possible arbitrary opts after the defined opts, due to @opts directive flag '-any|-arbitrary true' - dict for {o oval} $opts { - if {![dict exists $ordered_opts $o]} { - dict set ordered_opts $o $oval - } - } - set opts $ordered_opts - #--------------------------------------- - - - set positionalidx 0 ;#index for unnamed positionals (both leaders and values) - set leadername_multiple "" - set leadernames_received [list] - - set num_leaders [llength $leaders] - - #---------------------------------------- - #Establish firm leaders ordering - set leaders_dict [dict create] - foreach lname [lrange $LEADER_NAMES 0 $num_leaders-1] { - dict set leaders_dict $lname {} - } - set leaders_dict [dict merge $leaders_dict $LEADER_DEFAULTS] - #---------------------------------------- - - set start_position $positionalidx - set nameidx 0 - #MAINTENANCE - (*nearly*?) same loop logic as for value - for {set ldridx 0} {$ldridx < [llength $leaders]} {incr ldridx} { - set leadername [lindex $LEADER_NAMES $nameidx] - #incr nameidx - set ldr [lindex $leaders $ldridx] - if {$leadername ne ""} { - set typelist [tcl::dict::get $argstate $leadername -type] - if {[llength $typelist] == 1} { - set clauseval $ldr - } else { - set clauseval [list] - incr ldridx -1 - foreach t $typelist { - incr ldridx - if {$ldridx > [llength $leaders]-1} { - set msg "Bad number of leaders for %caller%. Received [llength $clauseval] values ('$clauseval') for '$leadername', but requires [llength $leadername] values" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength [llength $leadername] ] -argspecs $argspecs]] $msg - } - lappend clauseval [lindex $leaders $ldridx] - } - } - - if {[tcl::dict::get $argstate $leadername -multiple]} { - #if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { - # #current stored ldr equals defined default - don't include default in the list we build up - # tcl::dict::set leaders_dict $leadername [list $clauseval] ;#important to treat first element as a list - #} else { - # tcl::dict::lappend leaders_dict $leadername $clauseval - #} - if {$leadername in $leadernames_received} { - tcl::dict::lappend leaders_dict $leadername $clauseval - } else { - tcl::dict::set leaders_dict $leadername [list $clauseval] - } - set leadername_multiple $leadername - } else { - tcl::dict::set leaders_dict $leadername $clauseval - set leadername_multiple "" - incr nameidx - } - lappend leadernames_received $leadername - } else { - if {$leadername_multiple ne ""} { - set typelist [tcl::dict::get $argstate $leadername_multiple -type] - if {[llength $typelist] == 1} { - set clauseval $ldr - } else { - set clauseval [list] - incr ldridx -1 - foreach t $typelist { - incr ldridx - if {$ldridx > [llength $leaders]-1} { - set msg "Bad number of leaders for %caller%. Received [llength $clauseval] values ('$clauseval') for '$leadername_multiple', but requires [llength $leadername_multiple] values." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength [llength $leadername_multiple] ] -argspecs $argspecs]] $msg - } - lappend clauseval [lindex $leaders $ldridx] - } - } - tcl::dict::lappend leaders_dict $leadername_multiple $clauseval - #name already seen - but must add to leadernames_received anyway (as with opts and values) - lappend leadernames_received $leadername_multiple - } else { - if {$LEADER_UNNAMED} { - tcl::dict::set leaders_dict $positionalidx $ldr - tcl::dict::set argstate $positionalidx $LEADERSPEC_DEFAULTS - tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS - lappend leadernames_received $positionalidx - } else { - set msg "Bad number of leaders for %caller%. Received more leaders than can be assigned to argument names. (set '@leaders -unnamed true' to allow unnamed leaders)" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list toomanyarguments [llength $values] index $positionalidx] -argspecs $argspecs]] $msg - } - } - } - set positionalidx [expr {$start_position + $ldridx + 1}] - } - #----------------------------------------------------- - #satisfy test parse_withdef_leaders_no_phantom_default - foreach leadername [dict keys $leaders_dict] { - if {[string is integer -strict $leadername]} { - #ignore leadername that is a positionalidx - #review - always trailing - could use break? - continue - } - if {$leadername ni $leadernames_received && ![dict exists $LEADER_DEFAULTS $leadername]} { - #remove the name with empty-string default we used to establish fixed order of names - #The 'leaders' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default. - dict unset leaders_dict $leadername - } - } - #----------------------------------------------------- - - set validx 0 - set valname_multiple "" - set valnames_received [list] - - set num_values [llength $values] - #------------------------------------------ - #Establish firm values ordering - ## Don't set values_dict to VAL_DEFAULTS - or order of values_dict will be intermittently wrong based on whether values have defaults - ## set values_dict $val_defaults - set values_dict [dict create] - foreach valname [lrange $VAL_NAMES 0 $num_values-1] { - #set ALL valnames to lock in positioning - #note - later we need to unset any optional that had no default and was not received (no phantom default) - dict set values_dict $valname {} - } - set values_dict [dict merge $values_dict $VAL_DEFAULTS] - #------------------------------------------ - set nameidx 0 - set start_position $positionalidx - #MAINTENANCE - (*nearly*?) same loop logic as for leaders - for {set validx 0} {$validx < [llength $values]} {incr validx} { - set valname [lindex $VAL_NAMES $nameidx] - set val [lindex $values $validx] - if {$valname ne ""} { - set valtypelist [tcl::dict::get $argstate $valname -type] - - set assign_d [_get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES $valnames_received $formdict] - set consumed [dict get $assign_d consumed] - set resultlist [dict get $assign_d resultlist] - if {[tcl::dict::get $argstate $valname -optional]} { - if {$consumed == 0} { - incr validx -1 - set valname_multiple "" - incr nameidx - continue - } - } else { - #required named arg - if {$consumed == 0} { - if {$valname ni $valnames_received} { - #puts stderr "_get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES" - set msg "Bad number of values for %caller%. Not enough remaining values to assign to required arguments (fail on $valname)." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingrequiredvalue $valname ] -argspecs $argspecs]] $msg - } else { - incr validx -1 - set valname_multiple "" - incr nameidx - continue - } - } - } - #assert can_assign != 0, we have at least one value to assign to clause - - if {[llength $valtypelist] == 1} { - set clauseval $val - } else { - #clauseval must contain as many elements as the max length of -types! - #(empty-string/default for optional (?xxx?) clause members) - set clauseval $resultlist - #_get_dict_can_assign has only validated clause-length and literals match - #we assign and leave further validation for main validation loop. - incr validx -1 - incr validx $consumed - if {$validx > [llength $values]-1} { - error "get_dict unreachable" - set msg "Bad number of values for %caller%. Received [llength $clauseval] values for clause '$valname', but requires up to [llength $valtypelist] values." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength [llength $valname] ] -argspecs $argspecs]] $msg - } - - #for {set i 0} {$i < $consumed} {incr i} { - # incr validx - # if {$validx > [llength $values]-1} { - # set msg "Bad number of values for %caller%. Received [llength $clauseval] values for clause '$valname', but requires up to [llength $valtypelist] values." - # return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength [llength $valname] ] -argspecs $argspecs]] $msg - # } - # #lappend clauseval [lindex $values $validx] - #} - } - - if {[tcl::dict::get $argstate $valname -multiple]} { - #if {[tcl::dict::exists $VAL_DEFAULTS $valname]} { - # #current stored val equals defined default - don't include default in the list we build up - # tcl::dict::set values_dict $valname [list $clauseval] ;#important to treat first element as a list - #} else { - # tcl::dict::lappend values_dict $valname $clauseval - #} - if {$valname in $valnames_received} { - tcl::dict::lappend values_dict $valname $clauseval - } else { - tcl::dict::set values_dict $valname [list $clauseval] - } - set valname_multiple $valname - } else { - tcl::dict::set values_dict $valname $clauseval - set valname_multiple "" - incr nameidx - } - lappend valnames_received $valname - } else { - if {$valname_multiple ne ""} { - set valtypelist [tcl::dict::get $argstate $valname_multiple -type] - if {[llength $valname_multiple] == 1} { - set clauseval $val - } else { - set clauseval [list] - incr validx -1 - for {set i 0} {$i < [llength $valtypelist]} {incr i} { - incr validx - if {$validx > [llength $values]-1} { - set msg "Bad number of values for %caller%. Received [llength $clauseval] values for clause '$valname_multiple', but requires [llength $valtypelist] values." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength [llength $valtypelist] ] -argspecs $argspecs]] $msg - } - lappend clauseval [lindex $values $validx] - } - } - tcl::dict::lappend values_dict $valname_multiple $clauseval - #name already seen - but must add to valnames_received anyway (as with opts and leaders) - lappend valnames_received $valname_multiple - } else { - if {$VAL_UNNAMED} { - tcl::dict::set values_dict $positionalidx $val - tcl::dict::set argstate $positionalidx $VALSPEC_DEFAULTS - tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS - lappend valnames_received $positionalidx - } else { - set msg "Bad number of values for %caller%. Received more values than can be assigned to argument names. (set '@values -unnamed true' to allow unnamed values)" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list toomanyarguments [llength $values] index $positionalidx] -argspecs $argspecs]] $msg - } - } - } - set positionalidx [expr {$start_position + $validx + 1}] - } - #----------------------------------------------------- - #satisfy test parse_withdef_values_no_phantom_default - foreach vname [dict keys $values_dict] { - if {[string is integer -strict $vname]} { - #ignore vname that is a positionalidx - #review - always trailing - could break? - continue - } - if {$vname ni $valnames_received && ![dict exists $VAL_DEFAULTS $vname]} { - #remove the name with empty-string default we used to establish fixed order of names - #The 'values' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default. - dict unset values_dict $vname - } - } - #----------------------------------------------------- - - if {$leadermax == -1} { - #only check min - if {$num_leaders < $leadermin} { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected at least $leadermin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - } - } else { - if {$num_leaders < $leadermin || $num_leaders > $leadermax} { - if {$leadermin == $leadermax} { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected exactly $leadermin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - } else { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - } - } - } - - if {$valmax == -1} { - #only check min - if {$num_values < $valmin} { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $valmin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg - } - } else { - if {$num_values < $valmin || $num_values > $valmax} { - if {$valmin == $valmax} { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $valmin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg - } else { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $valmin and $valmax inclusive" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg - } - } - } - - #assertion - opts keys are full-length option names if -any|-arbitrary was false or if the supplied option as a shortname matched one of our defined options - - - #opts explicitly marked as -optional 0 must be present - regardless of -any|-arbitrary (which allows us to ignore additional opts to pass on to next call) - #however - if -any|-arbitrary 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 SHOULD? 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 - - #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? - #example timing difference: - #struct::set difference {x} {a b} - #normal interp 0.18 u2 vs safe interp 9.4us - #if {[llength [set missing [struct::set difference $OPT_REQUIRED $flagsreceived]]]} { - # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" - #} - #if {[llength [set missing [struct::set difference $VAL_REQUIRED $valnames_received]]]} { - # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" - #} - #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us - if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { - set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadermissing $missing received $leadernames_received] -argspecs $argspecs]] $msg - #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - set api_opt_required [lmap v $OPT_REQUIRED {lindex [split $v |] end}] - if {[llength [set missing [punklib_ldiff $api_opt_required $flagsreceived]]]} { - set full_missing [dict get $lookup_optset $missing] - set msg "Required option missing for %caller%. missing flags: '$full_missing' are marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list optionmissing $full_missing received $flagsreceived] -argspecs $argspecs]] $msg - #arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs - } - if {[llength [set missing [punklib_ldiff $VAL_REQUIRED $valnames_received]]]} { - set msg "Required value missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list valuemissing $missing received $valnames_received] -argspecs $argspecs]] $msg - #arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - - #--------------------------------------------------------------------------------------------- - #maintain order of opts $opts values $values as caller may use lassign. - set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] - if {[llength $receivednames]} { - #flat zip of names with overall posn, including opts - #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] - set i -1 - set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] - } else { - set received_posns [list] - } - #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) - #(e.g using 'dict exists $received -flag') - # - but it can have duplicate keys when args/opts have -multiple 1 - #It is actually a list of paired elements - #--------------------------------------------------------------------------------------------- - - - #todo - truncate/summarize values in error messages - - #todo - allow defaults outside of choices/ranges - - #check types,ranges,choices - set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] - #set combined_defaults [tcl::dict::merge $VAL_DEFAULTS $OPT_DEFAULTS] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash - #puts "---opts_and_values:$opts_and_values" - #puts "---argstate:$argstate" - tcl::dict::for {argname v} $opts_and_values { - if {[string match -* $argname]} { - #get full option name such as -fg|-foreground from non-alias name such as -foreground - #if "@opts -any|-arbitrary true" - we may have an option that wasn't defined - if {[dict exists $lookup_optset $argname]} { - set argname [dict get $lookup_optset $argname] - } - } - set thisarg [tcl::dict::get $argstate $argname] - #set thisarg_keys [tcl::dict::keys $thisarg] - set thisarg_checks [tcl::dict::get $arg_checks $argname] - set is_multiple [tcl::dict::get $thisarg -multiple] - set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] - set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] - set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] - set has_default [tcl::dict::exists $thisarg -default] - if {$has_default} { - set defaultval [tcl::dict::get $thisarg -default] - } - set typelist [tcl::dict::get $thisarg -type] - set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] - set regexprepass [tcl::dict::get $thisarg -regexprepass] - set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 - set validationtransform [tcl::dict::get $thisarg -validationtransform] - - - if {$is_multiple} { - set vlist $v - } else { - set vlist [list $v] - } - set vlist_original $vlist ;#retain for possible final strip_ansi - - #review - validationtransform - if {$is_validate_ansistripped} { - #validate_ansistripped 1 - package require punk::ansi - set vlist_check [list] - foreach e $vlist { - lappend vlist_check [punk::ansi::ansistrip $e] - } - } else { - #validate_ansistripped 0 - set vlist_check $vlist - } - - switch -- [Dict_getdef $thisarg -ARGTYPE unknown] { - leader { - set dname leaders_dict - set argclass "Leading argument" - } - option { - set dname opts - set argclass Option - } - value { - set dname values_dict - set argclass "Trailing argument" - } - default { - set dname "_unknown_" ;#NA - set argclass "Unknown argument" - } - } - #reduce our validation requirements by removing values which match defaultval or match -choices - #(could be -multiple with -choicerestricted 0 where some selections match and others don't) - if {$argname in $receivednames && $has_choices} { - #-choices must also work with -multiple - #todo -choicelabels - set choiceprefix [tcl::dict::get $thisarg -choiceprefix] - set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] - set choiceprefixreservelist [Dict_getdef $thisarg -choiceprefixreservelist {}] - set choicerestricted [tcl::dict::get $thisarg -choicerestricted] - set choicemultiple [tcl::dict::get $thisarg -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set nocase [tcl::dict::get $thisarg -nocase] - set choices [Dict_getdef $thisarg -choices {}] - set choicegroups [Dict_getdef $thisarg -choicegroups {}] - set allchoices $choices - if {[dict size $choicegroups]} { - dict for {groupname groupmembers} $choicegroups { - lappend allchoices {*}$groupmembers - } - } - #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups - #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes - - - set idx 0 ;# - #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes - #assert llength $vlist == llength [dict get $dname $argname] - # (unless there was a default and the option wasn't specified) - set vlist_validate [list] - set vlist_check_validate [list] - foreach e $vlist e_check $vlist_check { - set allchoices_in_list 0 - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - #vlist and vlist_check can be list of lists if -multiple and -choicemultiple - #each e represents 0 or more choice selections - set c_list $e - set c_check_list $e_check - #todo? check if entire list matches default? - } else { - #only one choice at a time - ensure single entry in c_list c_check_list - set c_list [list $e] - set c_check_list [list $e_check] - } - - - #----------------------------------- - #fast fail on the wrong number of choices - if {[llength $c_list] < $choicemultiple_min} { - set msg "$argclass $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { - set msg "$argclass $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - #----------------------------------- - - set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list - foreach c $c_list c_check $c_check_list { - if {$nocase} { - set casemsg " (case insensitive)" - set choices_test [tcl::string::tolower $allchoices] - #Don't lcase the denylist - even in nocase mode! - #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] - set v_test [tcl::string::tolower $c_check] - } else { - set casemsg " (case sensitive)" - set v_test $c_check - set choices_test $allchoices - } - set choice_in_list 0 - set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? - if {!$matches_default} { - if {$choiceprefix} { - #can we handle empty string as a choice? It should just work - REVIEW/test - set choice_exact_match 0 - if {$c_check in $allchoices} { - #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing - set chosen $c_check - set choice_in_list 1 - set choice_exact_match 1 - } elseif {$v_test in $choices_test} { - #assert - if we're here, nocase must be true - #we know choice is present as full-length match except for case - #now we want to select the case from the choice list - not the supplied value - #we don't set choice_exact_match - because we will need to override the optimistic existing val below - #review - foreach avail [lsort -unique $allchoices] { - if {[string match -nocase $c $avail]} { - set chosen $avail - } - } - #assert chosen will always get set - set choice_in_list 1 - } else { - #puts ">>>> choiceprefixreservelist: $choiceprefixreservelist" - #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. - #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. - #in this block we can treat empty result from prefix match as a non-match - if {$nocase} { - #nocase implies that our entered value doesn't have to match case of choices - - #but we would still like to select the best match if there are case-dups. - #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete - # selecting Del will find Delete, del will match delete (and raise error) - # but DEL will also match delete rather than Delete - so again an error is raised. - #This is counterintuitive with -nocase - #This is probably such an edge case that best served with documentation as a feature-not-bug - #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? - #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. - - set bestmatch [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check] - if {$bestmatch eq "" || $bestmatch in $choiceprefixreservelist} { - set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $choices_test] {*}$choiceprefixreservelist] $v_test] - #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing - set chosen [lsearch -inline -nocase $allchoices $chosen] - set choice_in_list [expr {$chosen ne ""}] - } else { - set chosen $bestmatch - set choice_in_list 1 - } - } else { - set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check] - if {$chosen eq "" || $chosen in $choiceprefixreservelist} { - set choice_in_list 0 - } else { - set choice_in_list 1 - } - } - #override choice_in_list if in deny list - #don't allow prefixing for elements from -choiceprefixdenylist - #we still use all elements to calculate the prefixes though - #review - case difference edge cases in choiceprefixdenylist !todo - if {$chosen in $choiceprefixdenylist} { - set choice_in_list 0 - set chosen "" - } - } - - #override the optimistic existing val - if {$choice_in_list && !$choice_exact_match} { - if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { - if {$is_multiple} { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $idx $chosen - tcl::dict::set $dname $argname $existing - } else { - tcl::dict::set $dname $argname $chosen - } - } else { - if {$is_multiple} { - set existing_all [tcl::dict::get [set $dname] $argname] - lset existing_all $idx $choice_idx $chosen - tcl::dict::set $dname $argname $existing_all - } else { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $choice_idx $chosen - tcl::dict::set $dname $argname $existing - } - } - } - } else { - #value as stored in $dname is ok - set choice_in_list [expr {$v_test in $choices_test}] - } - } - - if {!$choice_in_list && !$matches_default} { - if {!$choicerestricted} { - #if {$is_multiple} { - # set existing [tcl::dict::get [set $dname] $argname] - # lset existing $idx $v_test - # tcl::dict::set $dname $argname $existing - #} else { - # tcl::dict::set $dname $argname $v_test - #} - lappend vlist_validate $c - lappend vlist_check_validate $c_check - } else { - #unhappy path - if {$choiceprefix} { - set prefixmsg " (or a unique prefix of a value)" - } else { - set prefixmsg "" - } - #review: $c vs $c_check for -badval? - set msg "$argclass '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname - } - } - incr choice_idx - } - - incr idx - } - #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation - #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - - #todo - don't add to validation lists if not in receivednames - if {$argname ni $receivednames} { - set vlist [list] - set vlist_check_validate [list] - } else { - if {[llength $vlist] && $has_default} { - set vlist_validate [list] - set vlist_check_validate [list] - foreach c $vlist c_check $vlist_check { - #for -choicemultiple with default that could be a list use 'ni' ?? review - if {$c_check ne $defaultval} { - lappend vlist_validate $c - lappend vlist_check_validate $c - } - } - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - } - - #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups - #assert: our vlist & vlist_check lists have been reduced to remove those - if {[llength $vlist] && !$is_allow_ansi} { - #allow_ansi 0 - package require punk::ansi - #do not run ta::detect on a list - foreach e $vlist { - if {[punk::ansi::ta::detect $e]} { - set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - #puts "argname:$argname v:$v is_default:$is_default" - #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. - #arguments that are at their default are not subject to type and other checks - - #don't validate defaults or choices that matched - #puts "---> opts_and_values: $opts_and_values" - #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" - #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} - - #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups - #assert [llength $vlist] == [llength $vlist_check] - set type [lindex $typelist 0] - if {[llength $vlist]} { - - switch -- $type { - literal { - foreach e $vlist { - if {$e ne $argname} { - set msg "$argclass '$argname' for %caller% requires literal value '$argname'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - } - } - } - any {} - list { - foreach e_check $vlist_check { - if {![tcl::string::is list -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[llength $e_check] < $checkval} { - set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[llength $e_check] > $checkval} { - set msg "$argclass '$argname for %caller% requires list with -maxsize $checkval. Received len:[llength $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - } - indexexpression { - foreach e_check $vlist_check { - if {[catch {lindex {} $e_check}]} { - set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - string - ansistring - globstring { - #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string - #we possibly don't want to always have to regex on things that don't pass the other more basic checks - # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) - # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) - # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead - # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function - # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) - # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail - - #todo? - way to validate both unstripped and stripped? - set pass_quick_list_e [list] - set pass_quick_list_e_check [list] - set remaining_e $vlist - set remaining_e_check $vlist_check - #review - order of -regexprepass and -regexprefail in original rawargs significant? - #for now -regexprepass always takes precedence - if {$regexprepass ne ""} { - foreach e $vlist e_check $vlist_check { - if {[regexp $regexprepass $e]} { - lappend pass_quick_list_e $e - lappend pass_quick_list_e_check $e_check - } - } - set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] - set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] - } - if {$regexprefail ne ""} { - foreach e $remaining_e e_check $remaining_e_check { - #puts "----> checking $e vs regex $regexprefail" - if {[regexp $regexprefail $e]} { - if {[tcl::dict::exists $thisarg -regexprefailmsg]} { - #review - %caller% ?? - set msg [tcl::dict::get $thisarg -regexprefailmsg] - } else { - set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" - } - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - switch -- $type { - ansistring { - #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi - #.. so we need to look at the original values in $vlist not $vlist_check - - #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? - #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? - package require punk::ansi - foreach e $remaining_e { - if {![punk::ansi::ta::detect $e]} { - set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - globstring { - foreach e $remaining_e { - if {![regexp {[*?\[\]]} $e]} { - set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - - if {[tcl::dict::size $thisarg_checks]} { - foreach e_check $remaining_e_check { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[tcl::string::length $e_check] < $checkval} { - set msg "$argclass '$argname' for %caller% requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::string::length $e_check] > $checkval} { - set msg "$argclass '$argname' for %caller% requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - } - number { - #review - consider effects of Nan and Inf - #NaN can be considered as 'technically' a number (or at least a special numeric value) - lassign {} low high ;#set both empty - set has_range 0 - if {[tcl::dict::exists $thisarg -range]} { - lassign [tcl::dict::get $thisarg -range] low high - if {"$low$high" ne ""} { - set has_range 1 - } - } - foreach e $vlist e_check $vlist_check { - if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} { - set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - if {$has_range} { - if {[::tcl::mathfunc::isnan $e]} { - set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - if {$low eq ""} { - if {$e_check > $high} { - set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } elseif {$high eq ""} { - if {$e_check < $low} { - set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } else { - if {$e_check < $low || $e_check > $high} { - set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - int { - #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive - if {[tcl::dict::exists $thisarg -range]} { - lassign [tcl::dict::get $thisarg -range] low high - if {"$low$high" ne ""} { - if {$low eq ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - #lowside unspecified - check only high - if {$e_check > $high} { - set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } elseif {$high eq ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - #highside unspecified - check only low - if {$e_check < $low} { - set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } else { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'integer'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - #high and low specified - if {$e_check < $low || $e_check > $high} { - set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } else { - foreach e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - double { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is double -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type double. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - if {[tcl::dict::size $thisarg_checks]} { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -range { - #todo - small-value double comparisons with error-margin? review - #todo - empty string for low or high - lassign $checkval low high - if {$e_check < $low || $e_check > $high} { - set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - bool { - foreach e_check $vlist_check { - if {![tcl::string::is boolean -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - dict { - foreach e_check $vlist_check { - if {[llength $e_check] %2 != 0} { - set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[tcl::dict::size $e_check] < $checkval} { - set msg "$argclass '$argname' for %caller% requires dict with -minsize $checkval. Received dict size:[dict size $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::dict::size $e_check] > $checkval} { - set msg "$argclass '$argname' for %caller% requires dict with -maxsize $checkval. Received dict size:[dict size $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - } - alnum - - alpha - - ascii - - control - - digit - - graph - - lower - - print - - punct - - space - - upper - - wordchar - - xdigit { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is $type -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - file - - directory - - existingfile - - existingdirectory { - foreach e $vlist e_check $vlist_check { - #//review - we may need '?' char on windows - if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { - #what about special file names e.g on windows NUL ? - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - if {$type eq "existingfile"} { - foreach e $vlist e_check $vlist_check { - if {![file exists $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } elseif {$type eq "existingdirectory"} { - foreach e $vlist e_check $vlist_check { - if {![file isdirectory $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } - } - char { - #review - char vs unicode codepoint vs grapheme? - foreach e $vlist e_check $vlist_check { - if {[tcl::string::length $e_check] != 1} { - set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } - } - - } - - if {$is_strip_ansi} { - set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach - if {[tcl::dict::get $thisarg -multiple]} { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict $argname $stripped_list - } - option { - tcl::dict::set opts $argname $stripped_list - } - value { - tcl::dict::set values_dict $argname $stripped_list - } - } - } else { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict [lindex $stripped_list 0] - } - option { - tcl::dict::set opts $argname [lindex $stripped_list 0] - } - value { - tcl::dict::set values_dict [lindex $stripped_list 0] - } - } - } - } - } - - - - return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived multis $multisreceived] - } - - - proc forms {id} { - set spec [get_spec $id] - if {[dict size $spec]} { - return [dict get $spec form_names] - } else { - return [list] - } - } - lappend PUNKARGS [list { - @id -id ::punk::args::synopsis - @cmd -name punk::args::synopsis -help\ - "Return synopsis for each form of a command id - on separate lines. - If -form is given, supply only - the synopsis for that form. - " - @opts - -form -type string -default * - -return -type string -default full -choices {full summary dict} - @values -min 1 -max -1 - cmditem -multiple 1 -optional 0 - }] - proc synopsis {args} { - set argd [punk::args::parse $args withid ::punk::args::synopsis] - - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - if {$has_punkansi} { - set I [punk::ansi::a+ italic] - set RST [punk::ansi::a] - } else { - set I "" - set RST "" - } - - ##set form * - ##if {[lindex $args 0] eq "-form"} { - ## set arglist [lrange $args 2 end] - ## set form [lindex $args 1] - ##} else { - ## set arglist $args - ##} - ##if {[llength $arglist] == 0} { - ## error "punk::args::synopsis expected command id possibly with trailing subcommands/args" - ##} - ##set id [lindex $arglist 0] - ##set cmdargs [lrange $arglist 1 end] - - lassign [dict values $argd] leaders opts values - set form [dict get $opts -form] - set opt_return [dict get $opts -return] - set cmditems [dict get $values cmditem] - set id [lindex $cmditems 0] - set cmdargs [lrange $cmditems 1 end] - - - set spec [get_spec $id] - if {$spec eq ""} { - return - } - set form_names [dict get $spec form_names] - if {$form ne "*"} { - if {[string is integer -strict $form]} { - set f [lindex $form_names $form] - if {$f ne ""} { - set form_names [list $f] - } else { - set form_names [list] - } - } else { - if {$form in $form_names} { - set form_names [list $form] - } else { - set form_names [list] - } - } - } - - set SYND [dict create] - set syn "" - #todo - -multiple etc - foreach f $form_names { - set SYNLIST [list] - dict set SYND $f [list] - append syn "$id" - set forminfo [dict get $spec FORMS $f] - foreach argname [dict get $forminfo LEADER_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set ARGD [dict create argname $argname class leader] - if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - set display [lindex [dict get $arginfo -choices] 0] - } elseif {[dict get $arginfo -type] eq "literal"} { - set display $argname - } else { - set display $I$argname$RST - } - if {[dict get $arginfo -optional]} { - append syn " ?$display?" - } else { - append syn " $display" - } - dict set ARGD type [dict get $arginfo -type] - dict set ARGD optional [dict get $arginfo -optional] - dict set ARGD display $display - dict lappend SYND $f $ARGD - } - foreach argname [dict get $forminfo OPT_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set ARGD [dict create argname $argname class option] - set tp [dict get $arginfo -type] - if {[dict get $arginfo -optional]} { - if {[dict get $arginfo -multiple]} { - if {$tp eq "none"} { - set display "?$argname?..." - } else { - set display "?$argname <$tp>?..." - } - } else { - if {$tp eq "none"} { - set display "?$argname?" - } else { - set display "?$argname <$tp>?" - } - } - } else { - if {[dict get $arginfo -multiple]} { - if {$tp eq "none"} { - set display "$argname ?$argname...?" - } else { - set display "$argname <$tp> ?$argname <$tp>?..." - } - } else { - if {$tp eq "none"} { - set display $argname - } else { - set display "$argname <$tp>" - } - } - } - append syn " $display" - dict set ARGD type [dict get $arginfo -type] - dict set ARGD optional [dict get $arginfo -optional] - dict set ARGD display $display - dict lappend SYND $f $ARGD - } - foreach argname [dict get $forminfo VAL_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set typelist [dict get $arginfo -type] - if {[llength $typelist] == 1} { - set tp [lindex $typelist 0] - if {$tp eq "literal"} { - set clause [lindex $argname end] - } elseif {[string match literal(*) $tp]} { - set match [string range $tp 8 end-1] - set clause $match - } else { - set clause $I$argname$RST - } - } else { - set n [expr {[llength $typelist]-1}] - set name_tail [lrange $argname end-$n end];#if there are enough tail words in the argname to match -types - set clause "" - foreach typespec $typelist elementname $name_tail { - #elementname will commonly be empty - if {[string match {\?*\?} $typespec]} { - set tp [string range $typespec 1 end-1] - set member_optional 1 - } else { - set tp $typespec - set member_optional 0 - } - if {$tp eq "literal"} { - set c $elementname - } elseif {[string match literal(*) $tp]} { - set match [string range $tp 8 end-1] - set c $match - } else { - set c $I$tp$RST - } - if {$member_optional} { - append clause " " "(?$c?)" - } else { - append clause " " $c - } - } - set clause [string trimleft $clause] - } - - set ARGD [dict create argname $argname class value] - if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} { - if {[dict get $arginfo -multiple]} { - #set display "?$I$argname$RST?..." - set display "?$clause?..." - } else { - set display "?$clause?" - #if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - # set display "?[lindex [dict get $arginfo -choices] 0]?" - #} elseif {[dict get $arginfo -type] eq "literal"} { - # set display "?$argname?" - #} else { - # set display "?$I$argname$RST?" - #} - } - } else { - if {[dict get $arginfo -multiple]} { - #set display "$I$argname$RST ?$I$argname$RST?..." - set display "$clause ?$clause?..." - } else { - set display $clause - #if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - # set display "[lindex [dict get $arginfo -choices] 0]" - #} elseif {[dict get $arginfo -type] eq "literal"} { - # set display $argname - #} else { - # set display "$I$argname$RST" - #} - } - } - append syn " $display" - dict set ARGD type [dict get $arginfo -type] - dict set ARGD optional [dict get $arginfo -optional] - dict set ARGD display $display - dict lappend SYND $f $ARGD - } - append syn \n - } - switch -- $opt_return { - full { - return [string trim $syn \n] - } - summary { - set summary "" - dict for {form arglist} $SYND { - append summary $id - set class_state leader - set option_count 0 - set value_count 0 - foreach ainfo $arglist { - switch -- [dict get $ainfo class] { - leader { - append summary " [dict get $ainfo display]" - } - option { - incr option_count - } - value { - incr value_count - if {$class_state ne "value"} { - if {$option_count > 0} { - append summary " ?options ($option_count defined)?" - } - set class_state value - } - append summary " [dict get $ainfo display]" - } - } - } - if {$value_count == 0 && $option_count > 0} { - append summary " ?options ($option_count defined)?" - } - append summary \n - } - set summary [string trim $summary \n] - return $summary - } - dict { - return $SYND - } - } - } - - - lappend PUNKARGS [list { - @id -id ::punk::args::synopsis_summary - @cmd -name punk::args::synopsis_summary -help\ - "Reduce the width of a synopsis string - by coalescing options to ?options?... - synopsis string may be arbitrarily marked - up with ANSI codes." - @opts - @values -min 1 -max -1 - synopsis -multiple 0 -optional 0 - }] - proc synopsis_summary {args} { - set argd [punk::args::parse $args withid ::punk::args::synopsis_summary] - set synopsis [dict get $argd values synopsis] - set summary "" - foreach sline [split $synopsis \n] { - set sline [regsub -all {\s+} $sline " "] ;#normalize to single spacing only - review - set in_opt 0 - set line_out "" - set codestack [list] - set parts [punk::ansi::ta::split_codes_single $sline] - #basic - foreach {pt code} $parts { - set charlist [split $pt ""] - for {set i 0} {$i < [llength $charlist]} {incr i} { - set c [lindex $charlist $i] - - switch -- $c { - ? { - if {!$in_opt} { - set in_opt 1 - } else { - - } - } - " " { - if {!$in_opt} { - append line_out " " - } else { - set in_opt - } - } - default { - if {!$in_opt} { - append line_out $c - } - } - } - } - if {$code ne ""} { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set codestack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set codestack [list $code] - } elseif {[punk::ansi::codetype::is_sgr $code]} { - #basic simplification first - remove straight dupes - set dup_posns [lsearch -all -exact $codestack $code] ;#must be -exact because of square-bracket glob chars - set codestack [lremove $codestack {*}$dup_posns] - lappend codestack $code - } else { - #? ignore other ANSI codes? - } - } - } - if {[string match -* $plain_s] || [string match ?- $plain_s]} { - } - } - return $summary - } - - lappend PUNKARGS [list { - @id -id ::punk::args::TEST - @opts -optional 0 - -o1 -default 111 -help "opt 1 mandatory" - @opts -optional 1 - -o2 -default 222 -help "opt 2 optional" - @values -min 0 -max 1 - v -help\ - "v1 optional" - }] - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::lib { - variable PUNKARGS - tcl::namespace::export * - tcl::namespace::path [list [tcl::namespace::parent]] - #*** !doctools - #[subsection {Namespace punk::args::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 flatzip {l1 l2} { - concat {*}[lmap a $l1 b $l2 {list $a $b}] - } - - if {[info commands lseq] ne ""} { - #tcl 8.7+ lseq significantly faster, especially for larger ranges - #The internal rep can be an 'arithseries' with no string representation - proc zero_based_posns {count} { - if {$count < 1} {return} - lseq 0 $count-1 - } - } else { - proc zero_based_posns {count} { - if {$count < 1} {return} - lsearch -all [lrepeat $count 0] * - } - } - - #return list of single column-width marks - possibly with ansi - proc choiceinfo_marks {choice choiceinfodict} { - set marks [list] - if {[dict exists $choiceinfodict $choice]} { - set cinfo [dict get $choiceinfodict $choice] - foreach info $cinfo { - if {[lindex $info 0] eq "doctype"} { - switch -- [lindex $info 1] { - punkargs { - lappend marks [punk::ns::Cmark punkargs brightgreen] - } - ensemble { - lappend marks [punk::ns::Cmark ensemble brightyellow] - } - oo { - lappend marks [punk::ns::Cmark oo brightcyan] - } - ooc { - lappend marks [punk::ns::Cmark ooc cyan] - } - ooo { - lappend marks [punk::ns::Cmark ooo cyan] - } - native { - lappend marks [punk::ns::Cmark native] - } - unknown { - lappend marks [punk::ns::Cmark unknown brightred] - } - } - } - } - } - return $marks - } - - - #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 -1] in calling scope ${[lindex [set x] 0]} !} - lappend PUNKARGS [list { - @id -id ::punk::args::lib::tstr - @cmd -name punk::args::lib::tstr -help\ - "A rough equivalent of js template literals - - Substitutions: - \$\{$varName\} - \$\{[myCommand]\} - (when -allowcommands flag is given)" - -allowcommands -default 0 -type none -help\ - "If -allowcommands is present, placeholder can contain commands - e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" - -undent -default 1 -type boolean -help\ - "undent/dedent the template lines. - The longest common prefix of whitespace is removed" - -indent -default "" -type string -help\ - "String with which to indent the template - prior to substitution. - If -undent is enabled, that is performed - first, then the indent is applied." - -paramindents -default line -choices {none line position} -choicelabels { - line\ - " Use leading whitespace in - the line in which the - placeholder occurs." - position\ - " Use the position in - the line in which the - placeholder occurs." - none\ - " No indents applied to - subsequent placeholder value - lines. This will usually - result in text awkwardly - ragged unless the source code - has also been aligned with the - left margin or the value has - been manually padded." - } -help\ - "How indenting is done for subsequent lines in a - multi-line placeholder substitution value. - The 1st line or a single line value is always - placed at the placeholder. - paramindents are performed after the main - template has been indented/undented. - (indenting by position does not calculate - unicode double-wide or grapheme cluster widths) - " - #choicelabels indented by 1 char is clearer for -return string - and reasonable in table - -return -default string -choices {dict list string args}\ - -choicelabels { - dict\ - " Return a dict with keys - 'template', 'params' and - 'errors'" - string\ - " Return a single result - being the string with - placeholders substituted." - list\ - " Return a 2 element list. - The first is itself a list - of plaintext portions of the - template, split at each point - at which placeholders were - present. The second element - of the outer list is a list - of placeholder values if -eval - is 1, or a list of the raw - placeholder strings if -eval - is 0." - args\ - " Return a list where the first - element is a list of template - plaintext sections as per the - 'list' return mechanism, but the - placeholder items are individual - items in the returned list. - This can be useful when passing - the expanded result of a tstr - command to another function - which expects the placeholders - as individual arguments" - } - -eval -default 1 -type boolean -help\ - "Whether to evaluate the \$\{\} placeholders. - When -return is string, -eval should generally be set to 1. - For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. - contained variables in that case should be braced or whitespace separated, or the variable - name is likely to collide with surrounding text. - e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" - @values -min 0 -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 - e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} - - Escape sequences such as \\n and unicode escapes are processed within placeholders. - " - }] - - proc tstr {args} { - #Too hard to fully eat-our-own-dogfood from within punk::args package - # - we use punk::args within the unhappy path only - #set argd [punk::args::get_by_id ::punk::lib::tstr $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 opt_eval [dict get $argd opts -eval] - - set templatestring [lindex $args end] - set arglist [lrange $args 0 end-1] - set opts [dict create\ - -allowcommands 0\ - -undent 1\ - -indent ""\ - -paramindents line\ - -eval 1\ - -return string\ - ] - if {"-allowcommands" in $arglist} { - set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] - dict set opts -allowcommands 1 - } - if {[llength $arglist] % 2 != 0} { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr expected option/value pairs prior to last argument" - } - } - dict for {k v} $arglist { - set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] - switch -- $fullk { - -indent - -undent - -paramindents - -return - -eval { - dict set opts $fullk $v - } - default { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" - } - } - } - } - set opt_allowcommands [dict get $opts -allowcommands] - set opt_paramindents [dict get $opts -paramindents] - set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] - if {$test_paramindents ni {none line position}} { - error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." - } - set opt_paramindents $test_paramindents - set opt_return [dict get $opts -return] - set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] - if {$opt_return eq ""} { - } - set opt_eval [dict get $opts -eval] - - - set nocommands "-nocommands" - if {$opt_allowcommands == 1} { - set nocommands "" - } - - set opt_undent [dict get $opts -undent] - if {$opt_undent} { - set templatestring [punk::args::lib::undent $templatestring] - } - set opt_indent [dict get $opts -indent] - if {$opt_indent ne ""} { - set templatestring [punk::args::lib::indent $templatestring $opt_indent] - } - - #set parts [_tstr_split $templatestring] - if {[string first \$\{ $templatestring] < 0} { - set parts [list $templatestring] - } else { - set parts [_parse_tstr_parts $templatestring] - } - set textchunks [list] - #set expressions [list] - set params [list] - set idx 0 - set errors [dict create] - set lastline "" ;#todo - first line has placeholder? - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach {pt expression} $parts { - lappend textchunks $pt - incr idx ;#pt incr - - #ignore last expression - if {$idx == [llength $parts]} { - break - } - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - #lappend expressions $expression - #---------------------- - #REVIEW - JMN - #TODO - debug punk::args loading of @dynamic defs - #puts "-- $expression" - #---------------------- - #brk1 - literal newline not {\n} - set leader "" - if {[set brk1 [string first \n $expression]] >= 0} { - #undent left of paramstart only for lines of expression that arent on opening ${..} line - set tail [string range $expression $brk1+1 end] - set leader [string repeat " " [string length $lastline]] - set undentedtail [punk::args::lib::undentleader $tail $leader] - #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] - set expression "[string range $expression 0 $brk1]$undentedtail" - } - if {$opt_eval} { - if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { - lappend params [string cat \$\{ $expression \}] - dict set errors [expr {[llength $params]-1}] $result - } else { - set result [string map [list \n "\n$leader"] $result] - lappend params $result - } - #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] - } else { - #JJJ - #REVIEW - #lappend params [subst -nocommands -novariables $expression] - lappend params $expression - } - append lastline [lindex $params end] ;#for current expression's position calc - - incr idx ;#expression incr - } - - if {$opt_return eq "dict"} { - return [dict create template $textchunks params $params errors $errors] - } - if {[dict size $errors]} { - set einfo "" - dict for {i e} $errors { - append einfo "parameter $i error: $e" \n - } - #REVIEW!!! - #TODO - fix - #puts stderr "tstr errors:\n$einfo\n" - } - - switch -- $opt_return { - list { - return [list $textchunks $params] - } - args { - #see example in tstr_test_one - return [list $textchunks {*}$params] - } - string { - #todo - flag to disable indent-matching behaviour for multiline param? - set out "" - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach pt $textchunks param $params { - if {$opt_paramindents eq "none"} { - append out $pt $param - } else { - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - if {$opt_paramindents eq "line"} { - regexp {(\s*).*} $lastline _all lastindent - } else { - #position - #TODO - detect if there are grapheme clusters - #This regsub doesn't properly space unicode double-wide chars or clusters - set lastindent "[regsub -all {\S} $lastline " "] " - } - if {$lastindent ne ""} { - set paramlines [split $param \n] - if {[llength $paramlines] == 1} { - append out $pt $param - } else { - append out $pt [lindex $paramlines 0] - foreach nextline [lrange $paramlines 1 end] { - append out \n $lastindent $nextline - } - } - } else { - append out $pt $param - } - append lastline $param - } - } - return $out - } - } - } - #test single placeholder tstr args where single placeholder must be an int - proc tstr_test_one {args} { - set argd [punk::args::parse $args withdef { - @cmd -name ::punk::args::lib::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 -return args {Select * from table where id = \$\{$id\} and etc... ;}] - } - - @values -min 2 -max 2 - template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - - but the tstr call in the example 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} - }] - 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]] ""] - set result [string cat [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 dollar sign - 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]] - } - - #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. - proc indent {text {prefix " "}} { - set result [list] - foreach line [split $text \n] { - if {[string trim $line] eq ""} { - lappend result "" - } else { - lappend result $prefix[string trimright $line] - } - } - return [join $result \n] - } - #dedent? - proc undent {text} { - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - regexp {^([\t ]*)} $lcp _m lcp - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - - #hacky - proc undentleader {text leader} { - #leader usually whitespace - but doesn't have to be - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - lappend nonblank "${leader}!!" - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - #regexp {^([\t ]*)} $lcp _m lcp - #lcp can be shorter than leader - set lcp [string range $lcp 0 [string length $leader]-1] - - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - #A version of textutil::string::longestCommonPrefixList - proc longestCommonPrefix {items} { - if {[llength $items] <= 1} { - return [lindex $items 0] - } - set items [lsort $items[unset items]] - set min [lindex $items 0] - set max [lindex $items end] - #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) - #(sort order nothing to do with length - e.g min may be longer than max) - if {[string length $min] > [string length $max]} { - set temp $min - set min $max - set max $temp - } - set n [string length $min] - set prefix "" - set i -1 - while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { - append prefix $c - } - return $prefix - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] -} - -tcl::namespace::eval punk::args::argdocbase { - namespace export * - #use a? to test and create literal ansi here rather than relying on punk::ansi package presence - #e.g - #% a? bold - #- bold │SGR 1│sample│␛[1msample - #- ──────┼─────┼──────┼────────── - #- RESULT│ │sample│␛[1msample - proc B {} {return \x1b\[1m} ;#a+ bold - proc N {} {return \x1b\[22m} ;#a+ normal - proc I {} {return \x1b\[3m} ;#a+ italic - proc NI {} {return \x1b\[23m} ;#a+ noitalic - -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::package { - variable PUNKARGS - lappend PUNKARGS [list { - @dynamic - @id -id "::punk::args::package::standard_about" - @cmd -name "%pkg%::about" -help\ - "About %pkg% - ... - " - -package_about_namespace -type string -optional 0 -help\ - "Namespace containing the package about procedures - Must contain " - -return\ - -type string\ - -default table\ - -choices {string table tableobject}\ - -choicelabels { - string\ - "A basic text layout" - table\ - "layout in table borders - (requires package: textblock)" - tableobject\ - "textblock::class::table object instance" - }\ - -help\ - "Choose the return type of the 'about' information" - topic -optional 1\ - -nocase 1\ - -default {*}\ - -choices {Description License Version Contact *}\ - -choicerestricted 0\ - -choicelabels { - - }\ - -multiple 1\ - -help\ - "Topic to display. Omit or specify as * to see all. - If * is included with explicit topics, * represents - the remaining unmentioned topics." - }] - proc standard_about {args} { - set argd [punk::args::parse $args withid ::punk::args::package::standard_about] - lassign [dict values $argd] leaders OPTS values received - - set pkgns [dict get $OPTS -package_about_namespace] - if {[info commands ${pkgns}::package_name] eq ""} { - error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" - } - set pkgname [${pkgns}::package_name] - - set opt_return [dict get $OPTS -return] - set all_topics [${pkgns}::about_topics] - if {![dict exists $received topic]} { - set topics $all_topics - } else { - # * represents all remaining topics not explicitly mentioned. - set val_topics [dict get $values topic] ;#if -multiple is true, this is a list - set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] - set topics [list] - foreach t $val_topics { - if {$t eq "*"} { - foreach a $all_topics { - if {$a ni $explicit_topics} { - lappend topics $a - } - } - } else { - lappend topics $t - } - } - } - if {$opt_return ne "string"} { - package require textblock ;#table support - set is_table 1 - set title [string cat {[} $pkgname {]} ] - set t [textblock::class::table new -title $title] - $t configure -frametype double -minwidth [expr {[string length $title]+2}] - - } else { - set topiclens [lmap t $topics {string length $t}] - set widest_topic [tcl::mathfunc::max {*}$topiclens] - set is_table 0 - set about "$pkgname\n" - append about [string repeat - $widest_topic] \n - } - foreach topic $topics { - if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { - set topic_contents [::${pkgns}::get_topic_$topic] - } else { - set topic_contents "" - } - if {!$is_table} { - set content_lines [split $topic_contents \n] - append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n - foreach ln [lrange $content_lines 1 end] { - append about [format %-${widest_topic}s ""] " " $ln \n - } - } else { - $t add_row [list $topic $topic_contents] - } - } - - if {!$is_table} { - return $about - } else { - if {$opt_return eq "tableobject"} { - return $t - } - set result [$t print] - $t destroy - return $result - } - } - -} - -#usually we would directly call arg definitions near the defining proc, -# so that the proc could directly use the definition in its parsing. -# -#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. -#arguably it may be more processor-cache-efficient to do together like this anyway. - -#can't do this here? - as there is circular dependency with punk::lib -#tcl::namespace::eval punk::args { -# foreach deflist $PUNKARGS { -# punk::args::define {*}$deflist -# } -# set PUNKARGS "" -#} - -lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -tcl::namespace::eval punk::args::system { - #*** !doctools - #[subsection {Namespace punk::args::system}] - #[para] Internal functions that are not part of the API - - #dict get value with default wrapper for tcl 8.6 - if {[info commands ::tcl::dict::getdef] eq ""} { - proc Dict_getdef {dictValue args} { - set keys [lrange $args 0 end-1] - if {[tcl::dict::exists $dictValue {*}$keys]} { - return [tcl::dict::get $dictValue {*}$keys] - } else { - return [lindex $args end] - } - } - } else { - #we pay a minor perf penalty for the wrap - interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef - } - - #name to reflect maintenance - home is punk::lib::ldiff - proc punklib_ldiff {fromlist removeitems} { - if {[llength $removeitems] == 0} {return $fromlist} - set result {} - foreach item $fromlist { - if {$item ni $removeitems} { - lappend result $item - } - } - return $result - } - -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::args [tcl::namespace::eval punk::args { - tcl::namespace::path {::punk::args::lib ::punk::args::system} - variable pkg punk::args - variable version - set version 0.1.8 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.9.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.9.tm deleted file mode 100644 index e64f2d54..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.9.tm +++ /dev/null @@ -1,7959 +0,0 @@ -# -*- 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: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.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 punk::args 0.1.9 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.1.9] -#[copyright "2024"] -#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] -#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] -#[require punk::args] -#[keywords module proc args arguments parse] -#[description] -#[para]Utilities for parsing proc args - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). -#[para] overview of punk::args -#[subsection Concepts] -#[para]There are 2 main conventions for parsing a proc args list -#[list_begin enumerated] -#[enum] -#[para]leading option-value pairs and flags followed by a list of values (Tcl style) -#[enum] -#[para]leading list of values followed by option-value pairs and flags (Tk style) -#[list_end] -#[para]There are exceptions in both Tcl and Tk commands regarding this ordering -#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style -#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] -#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. -#[para] -#[para]The basic principle is that a call to punk::args::parse is made near the beginning of the proc with a cacheable argument defining the parameters e.g -#[example { -# proc dofilestuff {args} { -# lassign [dict values [punk::args::parse $args withdef { -# @cmd -help "do some stuff with files e.g dofilestuff " -# @opts -type string -# #comment lines ok -# -directory -default "" -# -translation -default binary -# #setting -type none indicates a flag that doesn't take a value (solo flag) -# -nocomplain -type none -# @values -min 1 -max -1 -# }]] leaders opts values -# -# puts "translation is [dict get $opts -translation]" -# foreach f [dict values $values] { -# puts "doing stuff with file: $f" -# } -# } -#}] -#[para]The lines beginning with @ are usually optional in most cases and can be used to set defaults and some extra controls -#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values -#[para]valid @ lines being with @cmd @leaders @opts @values -#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. -#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. -#[para]e.g the result from the punk::args::parse call above may be something like: -#[para] leaders {} opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} -#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments -#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments -#[para]This could also be implemented entirely using args - and the @leaders category of arguments -#[example { -# proc dofilestuff {category args} { -# lassign [dict values [punk::args::parse $args withdef { -# @id -id ::dofilestuff -# -directory -default "" -# -translation -default binary -# -nocomplain -type none -# @values -min 2 -max 2 -# fileA -type existingfile 1 -# fileB -type existingfile 1 -# }]] leaders opts values -# puts "$category fileA: [dict get $values fileA]" -# puts "$category fileB: [dict get $values fileB]" -# } -#}] -#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 -#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored -#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, -#[para] or an additional call could be made to punk::args e.g -#[example { -# punk::args::parse [list $category $another_leading_arg] withdef { -# category -choices {cat1 cat2 cat3} -# another_leading_arg -type boolean -# } -#}] - -#*** !doctools -#[subsection Notes] -#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. -#[para] -#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. -#For functions that are part of an API a package may be more suitable. -#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) -#[example { -# proc test_switch {args} { -# set opts [dict create\\ -# -return "object"\\ -# -frametype "heavy"\\ -# -show_edge 1\\ -# -show_seps 0\\ -# -x a\\ -# -y b\\ -# -z c\\ -# -1 1\\ -# -2 2\\ -# -3 3\\ -# ] -# foreach {k v} $args { -# switch -- $k { -# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { -# dict set opts $k $v -# } -# default { -# error "unrecognised option '$k'. Known options [dict keys $opts]" -# } -# } -# } -# return $opts -# } -#}] -#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. -#[para] -# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. -# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. -#[para]use punk::lib::show_jump_tables to verify that a jump table exists. -#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous -#[example { -# proc test_prefix {args} { -# set opts [dict create\ -# -return string\ -# -frametype \uFFEF\ -# -show_edge \uFFEF\ -# -show_seps \uFFEF\ -# -x a\ -# -y b\ -# -z c\ -# -1 1\ -# -2 2\ -# -3 3\ -# ] -# if {[llength $args]} { -# set knownflags [dict keys $opts] -# } -# foreach {k v} $args { -# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v -# } -# return $opts -# } -#}] -#[para]There are many alternative args parsing packages a few of which are listed here. -#[list_begin enumerated] -#[enum]argp (pure tcl) -#[enum]parse_args (c implementation) -#[enum]argparse (pure tcl *) -#[enum]cmdline (pure tcl) -#[enum]opt (pure tcl) distributed with Tcl but considered deprecated -#[enum]The tcllib set of TEPAM modules (pure tcl) -#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. -#[list_end] -#[para] (* c implementation planned/proposed) -#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. -#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences -#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. -#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. -#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. -#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. -#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -#All ensemble commands are slower in a safe interp as they aren't compiled the same way -#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 -#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. -#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) -#ensembles: array binary clock dict info namespace string -#possibly file too, although that is generally hidden/modified in a safe interp -#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc -#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::args -#[list_begin itemized] -package require Tcl 8.6- -#optional? punk::trie -#optional? punk::textblock -#*** !doctools -#[item] [package {Tcl 8.6-}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -tcl::namespace::eval punk::args::register { - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] cooperative namespace punk::args::register - #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded - #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. - #[list_begin definitions] - - #Although the actual punk::args::define calls are not too sluggish, there could be *many*. - #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, - #especially since a fair proportion may be for documentation purposes rather than parsing args. - - # -- --- --- --- --- --- --- --- - #cooperative with packages that define some punk args but do so lazily - #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first - variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective - if {![info exists ::punk::args::register::NAMESPACES]} { - set ::punk::args::register::NAMESPACES [list] - } - # -- --- --- --- --- --- --- --- - - variable loaded_packages - if {![info exists loaded_packages]} { - set loaded_packages [list] ;#fully loaded - } - variable loaded_info - if {![info exists loaded_info]} { - set loaded_info [dict create] ;#time - } - variable scanned_packages - if {![info exists scanned_packages]} { - set scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages - } - variable scanned_info ;#time and idcount - if {![info exists scanned_info]} { - set scanned_info [dict create] - } - #some packages, e.g punk::args::tclcore document other namespaces. - #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources - variable namespace_docpackages - if {![info exists namespace_docpackages]} { - set namespace_docpackages [dict create] - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::register ---}] -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args { - - - variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. - - tcl::namespace::export {[a-z]*} - variable rawdef_cache - if {![info exists rawdef_cache]} { - set rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} - } - variable id_cache_rawdef - if {![info exists id_cache_rawdef]} { - set id_cache_rawdef [tcl::dict::create] - } - variable id_cache_spec - if {![info exists id_cache_spec]} { - set id_cache_spec [tcl::dict::create] - } - - variable argdefcache_unresolved - if {![info exists argdefcache_unresolved]} { - set argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) - } - - variable argdata_cache - if {![info exists argdata_cache]} { - set argdata_cache [tcl::dict::create] - } - - variable id_counter - if {![info exists id_counter]} { - set id_counter 0 - } - - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] Core API functions for punk::args - #[list_begin definitions] - - #todo - some sort of punk::args::cherrypick operation to get spec from an existing set - #todo - doctools output from definition - - - - - #todo? -synonym/alias ? (applies to opts only not values) - #e.g -background -aliases {-bg} -default White - #review - how to make work with trie prefix - #e.g - # -corner -aliases {-corners} - # -centre -aliases {-center -middle} - #We mightn't want the prefix to be longer just because of an alias - #we should get -co -ce and -m from the above as abbreviations - - set map [list %G% \x1b\[32m %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] - - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::define - #todo @preamble -help "move large block outside of table?" - @cmd -name punk::args::define -help\ - "Accepts a line-based definition of command arguments. - The definition can be supplied as a single text block or multiple as described - in the help information for 'text' below. - - Returns an id which is a key to the stored definition. - The id is taken from the supplied definition's @id -id line, or is an - automatically created id of the form 'autoid_'. - - At the time define is called - just the raw text arguments are stored for the id. - When the id is first used, for example with 'punk::args::parse $args withid $id', - the raw definition is parsed into a stored specifications dictionary. - - This specifications dictionary is structured for (optional) use within commands to - parse and validate the arguments - and is also used when retrieving definitions - (or parts thereof) for re-use. - - This can be used purely for documentation or called within a function to parse a mix - of leading values, switches/flags and trailing values. - - The overhead is favourably comparable with other argument processors - but none are - as fast as minimal code with a switch statement. For toplevel commands where a few - 10s of microseconds is immaterial, the validation and automated error formatting in - a table can be well worthwhile. For inner procs requiring utmost speed, the call can - be made only on the unhappy path when basic processing determines a mismatch - or it - can be left entirely as documentation for interactive use with: i ... - and for synopsis generation with: s ... - - The definition should usually contain an initial line of the form: @id -id ::somecmd - - Blank lines are ignored at the top level, ie if they are not part of another structure. - Similarly - lines at the top level beginning with the # character are ignored. - All other toplevel lines must consist of a leading word followed by paired arguments. - The arguments can be spread over multiple lines and contain lines of near-arbitrary - text if they are properly braced or double quoted and Tcl escaping for inner quotes - or unbalanced braces is maintained. - The line continuation character - (\\ at the end of the line) can be used to continue the set of arguments for - a leading word. - Leading words beginning with the @ character are directives controlling argument - parsing, defaults for subsequent arguments, and help display. - directives include: - %B%@id%N% ?opt val...? - directive-options: -id - %B%@cmd%N% ?opt val...? - directive-options: -name -help - %B%@leaders%N% ?opt val...? - (used for leading args that come before switches/opts) - directive-options: -min -max -unnamed - (also accepts options as defaults for subsequent arguments) - %B%@opts%N% ?opt val...? - directive-options: -any|-arbitrary - %B%@values%N% ?opt val...? - (used for trailing args that come after switches/opts) - directive-options: -min -max -unnamed - (also accepts options as defaults for subsequent arguments) - %B%@form%N% ?opt val...? - (used for commands with multiple forms) - directive-options: -form -synopsis - The -synopsis value allows overriding the auto-calculated - synopsis. - %B%@formdisplay%N% ?opt val...? - directive-options: -header (text for header row of table) - -body (override autogenerated arg info for form) - %B%@doc%N% ?opt val...? - directive-options: -name -url - %B%@seealso%N% ?opt val...? - directive-options: -name -url (for footer - unimplemented) - - Some other options normally present on custom arguments are available - to use with the @leaders @opts @values directives to set defaults - for subsequent lines that represent your custom arguments. - These 3 directives should occur in exactly this order - but can be - repeated with custom argument lines interspersed. - - An @id line can only appear once and should be the first item. - For the commandline usage to be displayed either on parsing error - or using the i .. function - an @id with -id is needed. - - All directives can be omitted, in which case every line represents - a custom leader, value or option. - All will be leaders by default if no options defined. - If options are defined (by naming with leading dash, or explicitly - specifying @opts) then the definitions prior to the options will be - categorised as leaders, and those following the options will be - categorised as values. - - Custom arguments are defined by using any word at the start of a - line that doesn't begin with @ or - - (except that adding an additionl @ escapes this restriction so - that @@somearg becomes an argument named @somearg) - - custom leading args, switches/options (names starting with -) - and trailing values also take spec-options: - - -type - defaults to string. If no other restrictions - are specified, choosing string does the least validation. - recognised types: - int - integer - number - list - indexexpression - dict - double - float - bool - boolean - char - file - directory - ansistring - globstring - (any of the types accepted by 'string is') - - The above all perform some validation checks - - string - (also any of the 'string is' types such as - xdigit, graph, punct, lower etc) - any - (unvalidated - accepts anything) - none - (used for switches only. Indicates this is - a 'solo' flag ie accepts no value) - - literal() - (exact match for string) - literalprefix() - (prefix match for string, other literal and literalprefix - entries specified as alternates using | are used in the - calculation) - - Note that types can be combined with | to indicate an 'or' - operation - e.g char|int - e.g literal(xxx)|literal(yyy) - e.g literalprefix(text)|literalprefix(binary) - (when all in the pipe-delimited type-alternates set are - literal or literalprefix - this is similar to the -choices - option) - - - and more.. (todo - document here) - If a typenamelist is supplied and has length > 1 - then -typeranges must be used instead of -range - The number of elements in -typeranges must match - the number of elements specified in -type. - - -typesynopsis - Must be same length as value in -type - This provides and override for synopsis display of types. - Any desired italicization must be applied manually to the - value. - - -optional - (defaults to true for flags/switches false otherwise) - For non flag/switch arguments - all arguments with - -optional true must sit consecutively within their group. - ie all optional leader arguments must be together, and all - optional value arguments must be together. Furthermore, - specifying both optional leaders and optional values will - often lead to ambiguous parsing results. Currently, all - optional non-flg/switch arguments should be either at the - trailing end of leaders or the trailing end of values. - Further unambiguous arrangements of optional args may be - made in future - but are currently considered 'unsupported' - -default - -multiple (for leaders & values defines whether - subsequent received values are stored against the same - argument name - only applies to final leader OR final value) - (for options/flags this allows the opt-val pair or solo - flag to appear multiple times - not necessarily contiguously) - -choices {} - A list of allowable values for an argument. - The -default value doesn't have to be in the list. - If a -type is specified - it doesn't apply to choice members. - It will only be used for validation if the -choicerestricted - option is set to false. If all choices are specified in values - within the -choicegroups dict, it is not necessary to specify them - in the -choices list. It is effectively a simpler form of - specifying choices when no grouping is required. It is fine to - use both -choices and -choicegroups e.g specifying all in -choices - and then including only some that need grouping in -choicegroups. - -choicelabels {} - keys are the values/argument names from -choices (or equivalently - members of value entries from the -choicegroups dict) - The values in the choicelabels dict are text values, possibly - containing newlines, that are displayed below each choice. - This is commonly a very basic summary of the choice. In the - case of a subcommand it may be a usage synopsis for further - arguments. - -choicerestricted - Whether values not specified in -choices or -choicegroups are - allowed. Defaults to true. - -choiceprefix - This specifies whether unique prefixes are able to be used - instead of the complete string. This is calculated using - tcl::prefix::match - and will display in the autogenerated - usage output. Defaults to true. - -choiceprefixdenylist {} - These choices should match exactly a choice entry in one of - the settings -choices or -choicegroups. - These will still be used in prefix calculation - but the full - choice argument must be entered to select the choice. - -choiceprefixreservelist {} - These choices are additional values used in prefix calculation. - The values will not be added to the list of available choices. - -choicegroups {} - Generally this would be used instead of -choices to allow - usage display of choices grouped by some name (or the empty - string for 'ungrouped' items which appear first). - See for example the output if 'i zlib' where choices of the - next subcommand are grouped by the names compression,channel, - streaming and checksumming. The -choices list is equivalent - to a -choicegroups dict entry where the key (groupname) is - the empty string. Both may be specified, in which case the - final list of available choices will be a union of the listed - values in -choices and the values from each choice group. - Choice values specified in -choices are effectively ungrouped - unless overridden by placing them in a choicegroup. - -choicemultiple (default {1 1}) - is a pair representing min and max number of choices - that can be present in the value. - If is a single integer it is equivalent to a - specified with the same integer for both min and max. - Max of -1 represents no upper limit. - If allows more than one choice the value is a list - consisting of items in the choices made available through - entries in -choices/-choicegroups. - -minsize (type dependant) - -maxsize (type dependant) - -range (type dependant - only valid if -type is a single item) - -typeranges (list with same number of elements as -type) - - - " - -dynamic -type boolean -default 0 -help\ - "If -dynamic is true, tstr interpolations of the form \$\{\$var\} - are re-evaluated on each call. - If the definition is being used not just as documentation, but is also - used within the function to parse args, e.g using punk::args::get_by_id, - then it should be noted that there is a slight performance penalty for the - dynamic case. - It is often not significant, perhaps depending on what vars/commands are - used but -dynamic true might be less desirable if the command is used in - inner loops in more performance-sensitive code. - " - @values -min 1 -max -1 - text -type string -multiple 1 -help\ - {Block(s) of text representing the argument definition for a command. - At least one must be supplied. If multiple, they are joined together with \n. - Using multiple text arguments may be useful to mix curly-braced and double-quoted - strings to have finer control over interpolation when defining arguments. - (this can also be handy for sections that pull resolved definition lines - from existing definitions (by id) for re-use of argument specifications and help text) - - e.g the following definition passes 2 blocks as text arguments - ${[punk::args::tclcore::argdoc::example { - punk::args::define { - @id -id ::myns::myfunc - @cmd -name myns::myfunc -help\ - "Description of command" - - %G%#The following option defines an option-value pair%R% - %G%#It may have aliases by separating them with a pipe |%R% - -fg|-foreground -default blah -type string -help\ - "In the result dict returned by punk::args::parse - the value used in the opts key will always be the last - entry, in this case -foreground" - %G%#The following option defines a flag style option (solo)%R% - -flag1 -default 0 -type none -help\ - "Info about flag1 - subsequent help lines auto-dedented by whitespace to left - of corresponding record start (in this case -flag1) - + first 4 spaces if they are all present. - This line has no extra indent relative to first line 'Info about flag1' - This line indented a further 6 chars" - - @values -min 1 -max -1 - %G%#Items that don't begin with * or - are value definitions%R% - v1 -type integer -default 0 - thinglist -type string -multiple 1 - } "@doc -name Manpage: -url [myfunc_manpage_geturl myns::myfunc]"}]} - } - }]] - - proc New_command_form {name} { - #probably faster to inline a literal dict create in the proc than to use a namespace variable - set leaderdirective_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - -ensembleparameter 0\ - ] - set optdirective_defaults [tcl::dict::create\ - -type string\ - -optional 1\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - -prefix 1\ - ] - set valdirective_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - - #form record can have running entries such as 'argspace' that aren't given to arg parser - #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict - return [dict create\ - argspace "leaders"\ - ARG_INFO [tcl::dict::create]\ - ARG_CHECKS [tcl::dict::create]\ - LEADER_DEFAULTS [tcl::dict::create]\ - LEADER_REQUIRED [list]\ - LEADER_NAMES [list]\ - LEADER_MIN ""\ - LEADER_MAX ""\ - LEADER_UNNAMED false\ - LEADERSPEC_DEFAULTS $leaderdirective_defaults\ - LEADER_CHECKS_DEFAULTS {}\ - OPT_DEFAULTS [tcl::dict::create]\ - OPT_REQUIRED [list]\ - OPT_NAMES [list]\ - OPT_ANY 0\ - OPT_MIN ""\ - OPT_MAX ""\ - OPT_SOLOS {}\ - OPTSPEC_DEFAULTS $optdirective_defaults\ - OPT_CHECKS_DEFAULTS {}\ - VAL_DEFAULTS [tcl::dict::create]\ - VAL_REQUIRED [list]\ - VAL_NAMES [list]\ - VAL_MIN ""\ - VAL_MAX ""\ - VAL_UNNAMED false\ - VALSPEC_DEFAULTS $valdirective_defaults\ - VAL_CHECKS_DEFAULTS {}\ - FORMDISPLAY [tcl::dict::create]\ - ] - - } - - proc errorstyle {args} { - #set or query the running config -errorstyle - #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? - #values: - #debug, enhanced, standard, basic, minimal - error todo - } - proc define {args} { - variable rawdef_cache - variable id_cache_rawdef - variable argdata_cache - if {[dict exists $rawdef_cache $args]} { - return [dict get [dict get $rawdef_cache $args] -id] - } else { - set id [rawdef_id $args] - if {[id_exists $id]} { - #we seem to be re-creating a previously defined id... - #clear any existing caches for this id - puts stderr "punk::args::define Redefinition of id:$id - clearing existing data" - - #dict unset argdata_cache $prevraw ;#silently does nothing if key not present - dict for {k v} $argdata_cache { - if {[dict get $v id] eq $id} { - dict unset argdata_cache $k - } - } - dict for {k v} $rawdef_cache { - if {[dict get $v -id] eq $id} { - dict unset rawdef_cache $k - } - } - dict unset id_cache_rawdef $id - } - set is_dynamic [rawdef_is_dynamic $args] - set defspace [uplevel 1 {::namespace current}] - dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic -defspace $defspace] - dict set id_cache_rawdef $id $args - return $id - } - } - - proc idquery_info {id} { - variable id_cache_rawdef - variable rawdef_cache - if {[dict exists $id_cache_rawdef $id]} { - set sep [string repeat - 40] - set rawdef [dict get $id_cache_rawdef $id] - if {[dict exists $rawdef_cache $rawdef]} { - set idinfo [dict get $rawdef_cache $rawdef] - } else { - set idinfo "" - } - set result "raw definition:" - append result \n $sep - append result \n $rawdef - append result \n $sep - append result \n "id info:" - append result \n $idinfo - append result \n $sep - variable argdata_cache - #lsearch -stride not avail (or buggy) in some 8.6 interps - search manually for now (2025). todo - modernize some time after Tcl 9.0/9.1 more widespread.(2027?) - #check for and report if id is present multiple times - set argdata_records [list] - dict for {k v} $argdata_cache { - if {[dict get $v id] eq $id} { - if {$k eq $rawdef} { - lappend argdata_records [list 1 $k $v] - } else { - lappend argdata_records [list 0 $k $v] - } - } - } - append result \n "argdata cache:" - if {![llength $argdata_records]} { - append result \n "(not present)" - } else { - append result \n "present [llength $argdata_records] time(s)" - foreach r $argdata_records { - lassign $r match k v - if {$match} { - append result \n " - present with same rawdef key" - } else { - append result \n " - present with different rawdef key" - append result \n " [punk::lib::indent $k { }]" - } - } - if {[llength $argdata_records] > 1} { - append result \n "*more than one record was not expected - review*" - } - } - append result \n $sep - return $result - } - } - - proc define2 {args} { - dict get [resolve {*}$args] id - } - - proc resolve {args} { - variable rawdef_cache - variable id_cache_rawdef - set defspace "" - if {[dict exists $rawdef_cache $args]} { - set cinfo [dict get $rawdef_cache $args] - set id [dict get $cinfo -id] - set is_dynamic [dict get $cinfo -dynamic] - if {[dict exists $cinfo -defspace]} { - set defspace [dict get $cinfo -defspace] - } - } else { - #should we really be resolving something that hasn't been defined? - set id [rawdef_id $args] - puts stderr "Warning: punk::args::resolve called with undefined id:$id" - set is_dynamic [rawdef_is_dynamic $args] - dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] - dict set id_cache_rawdef $id $args - } - - - variable argdata_cache - variable argdefcache_unresolved - - - set cache_key $args - #ideally we would use a fast hash algorithm to produce a short key with low collision probability. - #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) - #review - check if there is a built-into-tcl way to do this quickly - #for now we will just key using the whole string - #performance seems ok - memory usage probably not ideal - #quote from DKF 2021 - #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. - #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. - #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. - #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). - #> If dealing with very large amounts of data, using a database is probably a good plan. - - set textargs $args - if {![llength $args]} { - punk::args::get_by_id ::punk::args::define {} - return - } - #if {[lindex $args 0] eq "-dynamic"} { - # set is_dynamic [lindex $args 1] - # set textargs [lrange $args 2 end] - #} - - #experimental - set LVL 2 - - if {!$is_dynamic} { - if {[tcl::dict::exists $argdata_cache $cache_key]} { - return [tcl::dict::get $argdata_cache $cache_key] - } - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - if {[string first \$\{ $optionspecs] > 0} { - if {$defspace ne ""} { - #normal/desired case - #set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -paramindents none -allowcommands $optionspecs]] - } else { - #todo - deprecate/stop from happening? - puts stderr "punk::args::resolve calling tstr for id:$id with no known definition space (-defspace empty)" - set optionspecs [uplevel $LVL [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } - } - } else { - - if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { - set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel $LVL [list ::subst $param]] - } - } else { - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - #dynamic - double substitution required. - #e.g - # set DYN_CHOICES {${[::somewhere::get_choice_list]}} - # set RED [punk::ansi::a+ bold red] - # set RST [punk::ansi::a] - # punk::args::define { - # -arg -choices {${$DYN_CHOICES}} -help "${$RED}important info${$RST}" - #} - if {$defspace ne ""} { - set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } - #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) - if {[string first \$\{ $optionspecs] > 0} { - set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel $LVL [list ::subst $param]] - } - tcl::dict::set argdefcache_unresolved $cache_key $pt_params - } - } - #argdata_cache should be limited in some fashion or will be a big memory leak??? - if {[tcl::dict::exists $argdata_cache [list $optionspecs]]} { - #resolved cache version exists - return [tcl::dict::get $argdata_cache [list $optionspecs]] - } - } - - - - #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices - #default to 1 for convenience - - #checks with no default - #-minsize -maxsize -range - - - #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi - #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist - - #set opt_defaults [tcl::dict::create] - #set val_defaults [tcl::dict::create] - - #set opt_solos [list] - #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end - - set records [list] - set linebuild "" - - set linelist [split $optionspecs \n] - set lastindent "" - foreach ln $linelist { - if {[tcl::string::trim $ln] eq ""} {continue} - regexp {(\s*).*} $ln _all lastindent - break ;#break at first non-empty - } - #puts "indent1:[ansistring VIEW $lastindent]" - set in_record 0 - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - foreach rawline $linelist { - set recordsofar [tcl::string::cat $linebuild $rawline] - #ansi colours can stop info complete from working (contain square brackets) - #review - when exactly are ansi codes allowed/expected in record lines. - # - we might reasonably expect them in default values or choices or help strings - # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. - # - eg set line "set x \"a[a+ red]red[a]\"" - # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket - if {$has_punkansi} { - set test_complete [punk::ansi::ansistrip $recordsofar] - } else { - #review - #we only need to strip enough to stop interference with 'info complete' - set test_complete [string map [list \x1b\[ ""] $recordsofar] - } - if {![tcl::info::complete $test_complete]} { - #append linebuild [string trimleft $rawline] \n - if {$in_record} { - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. - #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. - #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. - #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) - #(note string first "" $str is fast and returns -1) - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline \n - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline \n - } else { - append linebuild $rawline \n - } - } else { - set in_record 1 - regexp {(\s*).*} $rawline _all lastindent - #puts "indent: [ansistring VIEW -lf 1 $lastindent]" - #puts "indent from rawline:$rawline " - append linebuild $rawline \n - } - } else { - set in_record 0 - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline - } else { - append linebuild $rawline - } - lappend records $linebuild - set linebuild "" - } - } - set cmd_info {} - set package_info {} - set id_info {} ;#e.g -children ?? - set doc_info {} - #set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table - set seealso_info {} - set keywords_info {} - ###set leader_min 0 - ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit - #set leader_max "" - #(common case of no leaders specified) - #set opt_any 0 - #set val_min 0 - #set val_max -1 ;#-1 for no limit - set DEF_definition_id $id - - #form_defs - set F [dict create _default [New_command_form _default]] - set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under - - #set ARGSPACE [dict create] ;#keyed on form - #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values - - set refs [dict create] - set record_type "" - set record_number -1 ;# - foreach rec $records { - set trimrec [tcl::string::trim $rec] - switch -- [tcl::string::index $trimrec 0] { - "" - # {continue} - } - incr record_number - set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict - if {[llength $record_values] % 2 != 0} { - #todo - avoid raising an error - store invalid defs keyed on id - error "punk::args::resolve - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" - } - # ---------------------------------------------------------- - # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. - #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! - #(form_ids_active is otherwise set in the @form handling block) - - #consider the following 2 line entry which is potentially dynamically included via a tstr: - # @form -form {* newform} - # @form -form {newform} -synopsis "cmd help ?stuff?" - #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. - #(because _default is usually 'taken over' by the first encountered form id) - #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record - #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. - - if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { - set patterns [dict get $record_values -form] - set record_form_ids [list] - foreach p $patterns { - if {[regexp {[*?\[\]]} $p]} { - #isglob - only used for matching existing forms - lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] - } else { - #don't test for existence - will define new form if necessary - lappend record_form_ids $p - } - } - #-form values could be globs that didn't match. record_form_ids could be empty.. - if {[llength $record_form_ids]} { - #only rename _default if it's the sole entry - if {[dict size $F] == 1 && [dict exists $F "_default"]} { - if {"_default" ni $record_form_ids} { - #only initial form exists - but we are mentioning new ones - #first rename the _default to first encountered new form id - #(just replace whole dict with new key - same data) - set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] - #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F - #we are only setting active because of the rename - @form is the way to change active forms list - set form_ids_active [lindex $record_form_ids 0] - } - } - foreach fid $record_form_ids { - if {![dict exists $F $fid]} { - if {$firstword eq "@form"} { - #only @form directly supplies keys - dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] - } else { - dict set F $fid [New_command_form $fid] - } - } else { - #update form with current record opts, except -form - if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } - } - } - } - } else { - #missing or empty -form - set record_form_ids $form_ids_active - if {$firstword eq "@form"} { - foreach fid $form_ids_active { - dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] - } - } - } - # ---------------------------------------------------------- - - set firstchar [tcl::string::index $firstword 0] - set secondchar [tcl::string::index $firstword 1] - if {$firstchar eq "@" && $secondchar ne "@"} { - set record_type "directive" - set directive_name $firstword - set at_specs $record_values - - switch -- [tcl::string::range $directive_name 1 end] { - dynamic { - set is_dynamic 1 - } - id { - #disallow duplicate @id line ? - #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) - - #id An id will be allocated if no id line present or the -id value is "auto" - - if {[dict exists $at_specs -id]} { - set thisid [dict get $at_specs -id] - if {$thisid ni [list $id auto]} { - error "punk::args::resolve @id mismatch existing: $id vs $thisid" - } - } - set id_info $at_specs - } - ref { - #a reference within the definition - #e.g see punk::args::tclcore ::after - #global reference dict - independent of forms - #ignore refs without an -id - #store all keys except -id - #complete overwrite if refid repeated later on - if {[dict exists $at_specs -id]} { - dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] - } - } - default { - #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple - #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) - #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) - #That is possibly too complicated and/or unnecessary? - #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? - - if {[dict exists $at_specs -id]} { - set copyfrom [get_spec [dict get $at_specs -id]] - #we don't copy the @id info from the source - #for now we only copy across if nothing set.. - #todo - bring across defaults for empty keys at targets? - #need to keep it simple enough to reason about behaviour easily.. - if {[dict size $copyfrom]} { - if {![dict size $cmd_info]} { - set cmd_info [dict get $copyfrom cmd_info] - } - if {![dict size $doc_info]} { - set doc_info [dict get $copyfrom doc_info] - } - - #foreach fid $record_form_ids { - # #only use elements with matching form id? - # #probably this feature mainly useful for _default anyway so that should be ok - # #cooperative doc sets specified in same file could share via known form ids too - # FORMDISPLAY has keys -header -body - # if {![dict size $F $fid $FORMDISPLAY]} { - # if {[dict exists $copyfrom FORMS $fid FORMDISPLAY]} { - # dict set F $fid FORMDISPLAY [dict get $copyfrom FORMS $fid FORMDISPLAY] - # } - # } - # #TODO - # #create leaders opts vals depending on position of @default line? - # #options on @default line to exclude/include sets??? - #} - } - } - } - form { - # arity system ? - #handle multiple parsing styles based on arities and keyword positions (and/or flags?) - #e.g see lseq manual with 3 different parsing styles. - #aim to produce a table/subtable for each - # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ - # -arities { - # 2 - # {3 anykeys {1 .. 1 to}} - # {4 anykeys {3 by}} - # {5 anykeys {1 .. 1 to 3 by}} - # }\ - # -fallback 1 - # ... - # @parser -synopsis "start 'count' count ??'by'? step?"\ - # -arities { - # {3 anykeys {1 count}} - # } - # ... - # @form -synopsis "count ?'by' step?"\ - # -arities { - # 1 - # {3 anykeys {1 by}} - # } - # - # see also after manual - # @form -arities {1} - # @form -arities { - # 1 anykeys {0 info} - # } - #todo - - #can we generate a form synopsis if -synopsis not supplied? - - #form id can be list of ints|names?, or * - if {[dict exists $at_specs -form]} { - set idlist [dict get $at_specs -form] - if {$idlist eq "*"} { - #* only applies to form ids that exist at the time - set idlist [dict keys $F] - } - set form_ids_active $idlist - } - #new form keys already created if they were needed (done for all records that have -form ) - } - package { - set package_info [dict merge $package_info $at_specs] - } - cmd { - #allow arbitrary - review - set cmd_info [dict merge $cmd_info $at_specs] - } - doc { - set doc_info [dict merge $doc_info $at_specs] - } - formdisplay { - #override the displayed argument table for the form. - #(formdisplay keys -header -body) - #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing - foreach fid $record_form_ids { - tcl::dict::set F $fid FORMDISPLAY [dict merge [tcl::dict::get $F $fid FORMDISPLAY] $at_specs] - } - } - opts { - foreach fid $record_form_ids { - if {[tcl::dict::get $F $fid argspace] eq "values"} { - error "punk::args::resolve - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" - } - tcl::dict::set F $fid argspace "options" - set tmp_optspec_defaults [dict get $F $fid OPTSPEC_DEFAULTS] - - foreach {k v} $at_specs { - switch -- $k { - -form { - #review - handled above - } - -any - -arbitrary - - -anyopts { - #set opt_any $v - tcl::dict::set F $fid OPT_ANY $v - } - -min { - dict set F $fid OPT_MIN $v - } - -max { - #if no -max explicitly specified, and llength OPT_NAMES == 0 and OPT_ANY == 0 - -max will be set to 0 below. - dict set F $fid OPT_MAX $v - } - -minsize - -maxsize - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted { - #review - only apply to certain types? - tcl::dict::set tmp_optspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_optspec_defaults $k2 - } - } - -type { - #v is a typelist - #foreach t $v { - # #validate? - #} - tcl::dict::set tmp_optspec_defaults -type $v - } - -range { - if {[dict exists $at_specs -type]} { - set tp [dict get $at_specs -type] - } else { - set tp [dict get $tmp_optspec_defaults -type] - } - if {[llength $tp] == 1} { - tcl::dict::set tmp_optspec_defaults -typeranges [list $v] - } else { - error "punk::args::resolve Bad @opt line. -type has length [llength $tp] (-type $tp). -range only applies to single-item type. Use -typeranges instead. @id:$DEF_definition_id" - } - } - -typeranges { - if {[dict exists $at_specs -type]} { - set tp [dict get $at_specs -type] - } else { - set tp [dict get $tmp_optspec_defaults -type] - } - if {[llength $tp] != [llength $v]} { - error "punk::args::resolve Bad @opt line. -type has length [llength $tp] (-type $tp). -typeranges has length [llength $v]. Lengths must match. @id:$DEF_definition_id" - } - tcl::dict::set tmp_optspec_defaults -typeranges $v - } - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -validationtransform { - #allow overriding of defaults for options that occur later - tcl::dict::set tmp_optspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -multiple - - -prefix { - #check is bool - if {![string is boolean -strict $v]} { - error "punk::args::resolve - Option '$k' has value '$v'of wrong type in @opts line. Must be boolean @id:$DEF_definition_id" - } - tcl::dict::set tmp_optspec_defaults $k $v - } - default { - set known { -any -anyopts -arbitrary -form -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\ - -type -range -typeranges -default -typedefaults - -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::resolve - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" - } - } - } - tcl::dict::set F $fid OPTSPEC_DEFAULTS $tmp_optspec_defaults - } ;# end foreach record_form_ids - } - leaders { - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] in [list options values]} { - error "punk::args::resolve - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" - } - set tmp_leaderspec_defaults [dict get $F $fid LEADERSPEC_DEFAULTS] - - foreach {k v} $at_specs { - switch -- $k { - -form { - #review - handled above - } - -min - - -minvalues { - if {$v < 0} { - error "punk::args::resolve - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MIN $v - #if {$leader_max == 0} { - # set leader_max -1 - #} - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::resolve - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MAX $v - } - -choiceprefix - - -choicerestricted { - if {![string is boolean -strict $v]} { - error "punk::args::resolve - invalid type of value '$v' for key '$k' in @leaders line. Must be boolean @id:$DEF_definition_id" - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -choiceinfo - -choicelabels { - if {[llength $v] %2 != 0} { - error "punk::args::resolve - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - #-choicegroups? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_leaderspec_defaults $k2 - } - } - -type { - #$v is a list of types - #foreach t $v { - #validate? - #} - #switch -- $v { - # int - integer { - # set v int - # } - # char - character { - # set v char - # } - # bool - boolean { - # set v bool - # } - # dict - dictionary { - # set v dict - # } - # list { - - # } - # index { - # set v indexexpression - # } - # default { - # #todo - disallow unknown types unless prefixed with custom- - # } - #} - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -range { - tcl::dict::set tmp_leaderspec_defaults -range $v - } - -typeranges { - tcl::dict::set tmp_leaderspec_defaults -range $v - } - -minsize - -maxsize - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefixdenylist - -choiceprefixreservelist - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform { - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -multiple { - if {![string is boolean -strict $v]} { - error "punk::args::resolve - invalid type of value '$v' for key '$k' in @leaders line. Must be boolean @id:$DEF_definition_id" - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -unnamed { - if {![string is boolean -strict $v]} { - error "punk::args::resolve - invalid type of value '$v' for key '$k' in @leaders line. Must be boolean @id:$DEF_definition_id" - } - dict set F $fid LEADER_UNNAMED $v - } - -ensembleparameter { - #review - tcl::dict::set tmp_leaderspec_defaults $k $v - #error "punk::args::resolve - -ensembleparameter not supported as a default for @leaders - only valid on actual leader arguments" - } - default { - set known { -min -form -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\ - -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted\ - -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - -unnamed\ - } - error "punk::args::resolve - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid LEADERSPEC_DEFAULTS $tmp_leaderspec_defaults - - } ;#end foreach record_form_ids - - } - values { - foreach fid $record_form_ids { - dict set F $fid argspace "values" - - set tmp_valspec_defaults [dict get $F $fid VALSPEC_DEFAULTS] - - foreach {k v} $at_specs { - switch -- $k { - -form { - #review - handled above - } - -min - - -minvalues { - if {$v < 0} { - error "punk::args::resolve - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" - } - #set val_min $v - dict set F $fid VAL_MIN $v - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::resolve - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" - } - #set val_max $v - dict set F $fid VAL_MAX $v - } - -minsize - -maxsize - -choices - -choicemultiple - -choicecolumns - - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_valspec_defaults $k $v - } - -choiceinfo - -choicegroups { - if {[llength $v] % 2 != 0} { - error "punk::args::resolve - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - # -choicegroups ?? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_valspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - index { - set v indexexpression - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -range { - tcl::dict::set tmp_valspec_defaults -range $v - } - -typeranges { - tcl::dict::set tmp_valspec_defaults -typeranges $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -multiple { - if {![string is boolean -strict $v]} { - error "punk::args::resolve - invalid type of value '$v' for key '$k' in @values line. Must be boolean @id:$DEF_definition_id" - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform { - tcl::dict::set tmp_valspec_defaults $k $v - } - -unnamed { - if {![string is boolean -strict $v]} { - error "punk::args::resolve - invalid type of value '$v' for key '$k' in @values line. Must be boolean @id:$DEF_definition_id" - } - dict set F $fid VAL_UNNAMED $v - } - default { - set known { -type -range -typeranges\ - -min -form -minvalues -max -maxvalues\ - -minsize -maxsize\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\ - -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted\ - -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - -unnamed\ - } - error "punk::args::resolve - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid VALSPEC_DEFAULTS $tmp_valspec_defaults - } - - } - seealso { - #todo! - #like @doc, except displays in footer, multiple - sub-table? - set seealso_info [dict merge $seealso_info $at_specs] - } - keywords { - #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? - set keywords_info [dict merge $keywords_info $at_specs] - } - default { - error "punk::args::resolve - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @formdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" - } - } - #record_type directive - continue - } elseif {$firstchar eq "-"} { - set argdef_values $record_values - #Note that we can get options defined with aliases e.g "-x|-suppress" - #Here we store the full string as the argname - but in the resulting dict upon parsing it will have the final - # entry as the key for retrieval e.g {leaders {} opts {-suppress true} values {} ...} - - #we can also have longopts within the list e.g "-f|--filename=" - #This accepts -f or --filename= - # (but not --filename ) - #if the clausemember is optional - then the flag can act as a solo, but a parameter can only be specified on the commandline with an = - #e.g "-x|--something= -type ?string? - #accepts all of: - # -x - # --something - # --something=blah - - - #while most longopts require the = some utilities (e.g fossil) - #accept --longname - #(fossil accepts either --longopt or --longopt=) - #For this reason, "-f|--filename" is different to gnu-style longopt "-f|--filename=" - - #for "--filename=" we can specify an 'optional' clausemember using for example -type ?string? - - #4? cases - #1) - #--longopt - # (not really a longopt - can only parse with --longopt - [optional member not supported, but could be solo if -type none]) - #2) - #--longopt= - # (gnu style longopt - parse with --longopt= - solo allowed if optional member - does not support solo via -type none) - #3) - #--longopt|--longopt= -types int - # (mixed - as fossil does - parse with --longopt= or --longopt [optional member not supported?]) - #4) - # --xxx|--longopt= -types {?int?} - #(repeating such as --longopt --longopt= not valid?) - #redundant? - #ie --longopt|--longopt= -types {?int?} - # equivalent to - # --longopt= -types {?int?} - #allow parsing -xxx only as solo and --longopt as solo or --longopt=n ? - - #the above set would not cover the edge-case where we have an optional member but we don't want --longopt to be allowed solo - #e.g - #-soloname|--longopt= -types ?int? - #allows parsing "-soloname" or "--longopt" or "--longopt=n" - #but what if we want it to mean only accept: - # "-soloname" or "--longopt=n" ?? - - #we deliberately don't support - #--longopt -type ?type? - #or -opt -type ?type? - #as this results in ambiguities and more complexity in parsing depending on where flag occurs in args compared to positionals - - #for these reasons - we can't only look for leading -- here to determine 'longopt' - - - set argname $firstword - - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - #do some basic validation here - #1 "-type none" would not be valid for "--filename=" - #2 a -type can only be optional (specified as -type ?xxx?) if at least one entry in the argname has a trailing = - #3 require --longopt if has a trailing =. ie disallow -opt= ? - - set has_equal 0 - set optaliases [split $firstword |] - if {[lsearch $optaliases *=] >=0} { - set has_equal 1 - } - #todo - if no -type specified in this flag record, we still need to check the default -type from the @opts record - which could have been - #overridden from just 'string' - if {[tcl::dict::exists $argdef_values -type]} { - set tp [tcl::dict::get $argdef_values -type] - if {[llength $tp] != 1} { - #clauselength > 1 not currently supported for flags - #e.g -myflag -type {list int} - # e.g called on commandline with cmd -myflag {a b c} 3 - #review - seems an unlikely and complicating feature to allow - evidence of tools using/supporting this in the wild not known of. - error "punk::args::resolve - Multiple space-separated arguments (as indicated by -type having multiple entries) for a flag are not supported. flag $argname -type '$tp' @id:$DEF_definition_id" - } - if {$argname eq "--"} { - if {$tp ne "none"} { - #error to explicitly attempt to configure -- as a value-taking option - error "punk::args::resolve - special flag named -- cannot be configured as a value-accepting flag. set -type none or omit -type from definition. @id:$DEF_definition_id" - } - } - if {$tp eq "none"} { - if {$has_equal} { - error "punk::args::resolve - flag type 'none' (indicating non-parameter-taking flag) is not supported when any flag member ends with = (indicating gnu-longopt style possibly taking a parameter). flag $argname -type '$tp' @id:$DEF_definition_id" - } - } elseif {[string match {\?*\?} $tp]} { - #optional flag value - if {!$has_equal} { - error "punk::args::resolve - Optional flag parameter (as indicated by leading & trailing ?) is not supported when no flag member ends with = (indicating gnu-longopt style possibly taking a parameter). flag $argname -type '$tp' @id:$DEF_definition_id" - } - } - } - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - - tcl::dict::set argdef_values -ARGTYPE option - - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - dict set F $fid argspace "options" - } elseif {[dict get $F $fid argspace] eq "values"} { - error "punk::args::resolve - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" - } - set record_type option - dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] - } - - set is_opt 1 - } else { - set argname $firstword - if {$firstchar eq "@"} { - #allow basic @@ escaping for literal argname that begins with @ - set argname [tcl::string::range $argname 1 end] - } - - set argdef_values $record_values - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - set record_type leader - tcl::dict::set argdef_values -ARGTYPE leader - #lappend leader_names $argname - set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] - if {$argname ni $temp_leadernames} { - lappend temp_leadernames $argname - tcl::dict::set F $fid LEADER_NAMES $temp_leadernames - } else { - #This can happen if the definition has repeated values - error "punk::args::resolve - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" - } - - if {[dict get $F $fid LEADER_MAX] >= 0} { - if {[dict get $F $fid LEADER_MAX] < [llength $temp_leadernames]} { - puts stderr "punk::args::resolve warning arg $argname LEADER_MAX == [dict get $F $fid LEADER_MAX] but [llength $temp_leadernames] leader names found @id:$DEF_definition_id" - dict set F $fid LEADER_MAX [llength $temp_leadernames] - } - } - } else { - set record_type value - tcl::dict::set argdef_values -ARGTYPE value - set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] - if {$argname ni $temp_valnames} { - lappend temp_valnames $argname - tcl::dict::set F $fid VAL_NAMES $temp_valnames - } else { - error "punk::args::resolve - arg $argname already present as value in '$rec' (command form:'$fid') @id:$DEF_definition_id" - } - #lappend val_names $argname - if {[dict get $F $fid VAL_MAX] >= 0} { - if {[dict get $F $fid VAL_MAX] < [llength $temp_valnames]} { - puts stderr "punk::args::resolve warning arg $argname VAL_MAX == [dict get $F $fid VAL_MAX] but [llength $temp_valnames] value names found @id:$DEF_definition_id" - dict set F $fid VAL_MAX [llength $temp_valnames] - } - } - } - } - - set is_opt 0 - } - - - #assert - we only get here if it is a value or flag specification line. - #assert argdef_values has been set to the value of record_values - - foreach fid $record_form_ids { - if {$is_opt} { - set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS] - } else { - if {[dict get $F $fid argspace] eq "values"} { - set spec_merged [dict get $F $fid VALSPEC_DEFAULTS] - } else { - set spec_merged [dict get $F $fid LEADERSPEC_DEFAULTS] - } - } - - # -> argopt argval - foreach {spec specval} $argdef_values { - #literal-key switch - bytecompiled to jumpTable - switch -- $spec { - -form { - - } - -type { - #todo - could be a list e.g {any int literal(Test)} - #case must be preserved in literal bracketed part - set typelist [list] - foreach typespec $specval { - set lc_typespec [tcl::string::tolower $typespec] - if {[string match {\?*\?} $lc_typespec]} { - set lc_type [string range $lc_typespec 1 end-1] - set optional_clausemember true - } else { - set lc_type $lc_typespec - set optional_clausemember false - } - #normalize here so we don't have to test during actual args parsing in main function - set normtype "" ;#assert - should be overridden in all branches of switch - switch -- $lc_type { - int - integer { - set normtype int - } - double - float { - #review - user may wish to preserve 'float' in help display - consider how best to implement - set normtype double - } - bool - boolean { - set normtype bool - } - char - character { - set normtype char - } - dict - dictionary { - set normtype dict - } - index - indexexpression { - set normtype indexexpression - } - "" - none - solo { - if {$is_opt} { - #review - are we allowing clauses for flags? - #e.g {-flag -type {int int}} - #this isn't very tcl like, where we'd normally mark the flag with -multiple true and - # instead require calling as: -flag -flag - #It seems this is a reasonably rare/unlikely requirement in most commandline tools. - - if {[llength $specval] > 1} { - #makes no sense to have 'none' in a clause - error "punk::args::resolve - invalid -type '$specval' for flag '$argname' ('none' in multitype) @id:$DEF_definition_id" - } - #tcl::dict::set spec_merged -type none - set normtype none - 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. - } - } else { - #solo only valid for flags - error "punk::args::resolve - invalid -type 'none|solo' for positional argument '$argname' (only valid for flags/options) @id:$DEF_definition_id" - } - } - any - anything { - set normtype any - } - ansi - ansistring { - set normtype ansistring - } - string - globstring { - set normtype $lc_type - } - literal { - if {$is_opt} { - error "punk::args::resolve - invalid -type 'literal' for flag argument '$argname' @id:$DEF_definition_id" - } - #value is the name of the argument - set normtype literal - } - default { - if {[string match literal* $lc_type]} { - #typespec may or may not be of form ?xxx? - set literal_tail [string range [string trim $typespec ?] 7 end] - set normtype literal$literal_tail - } else { - #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW - #tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - set normtype $lc_type - } - } - } - if {$optional_clausemember} { - lappend typelist ?$normtype? - } else { - lappend typelist $normtype - } - } - tcl::dict::set spec_merged -type $typelist - } - -typesynopsis { - set typecount [llength [tcl::dict::get $spec_merged -type]] - if {$typecount != [llength $specval]} { - error "punk::args::resolve - invalid -typesynopsis specification for argument '$argname'. -typesynopsis has [llength $specval] entries, but requires $typecount entries (one for each entry in -types. Use empty string list members for default) @id:$DEF_definition_id" - } - tcl::dict::set spec_merged -typesynopsis $specval - } - -solo - - -choices - -choicegroups - -choicemultiple - -choicecolumns - - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted - -choicelabels - -choiceinfo - - -minsize - -maxsize - -nocase - -multiple - - -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - - -regexprepass - -regexprefail - -regexprefailmsg - { - #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines - #review -solo 1 vs -type none ? conflicting values? - tcl::dict::set spec_merged $spec $specval - } - -range { - #allow simple case to be specified without additional list wrapping - #only multi-types require full list specification - #arg1 -type int -range {0 4} - #arg2 -type {int string} -range {{0 4} {"" ""}} - set typecount [llength [tcl::dict::get $spec_merged -type]] - if {$typecount == 1} { - tcl::dict::set spec_merged -typeranges [list $specval] - } else { - error "punk::args::resolve Bad @opt line. -type has length [llength $tp] (-type $tp). -range only applies to single-item type. Use -typeranges instead. @id:$DEF_definition_id" - } - } - -typeranges { - set typecount [llength [tcl::dict::get $spec_merged -type]] - if {$typecount != [llength $specval]} { - error "punk::args::resolve - invalid -typeranges specification for argument '$argname'. -typeranges has [llength $specval] entries, but requires $typecount entries (one for each entry in -types) @id:$DEF_definition_id" - } - tcl::dict::set spec_merged -typeranges $specval - } - -default { - #The -default is for when the entire clause is missing - #It doesn't necessarily have to have the same number of elements as the clause {llength $typelist} - #review - tcl::dict::set spec_merged -default $specval - if {![dict exists $argdef_values -optional]} { - tcl::dict::set spec_merged -optional 1 - } - } - -typedefaults { - set typecount [llength [tcl::dict::get $spec_merged -type]] - if {$typecount != [llength $specval]} { - error "punk::args::resolve - invalid -typedefaults specification for argument '$argname'. -typedefaults has [llength $specval] entries, but requires $typecount entries (one for each entry in -types) @id:$DEF_definition_id" - } - tcl::dict::set spec_merged -typedefaults $specval - } - -optional { - #applies to whole arg - not each -type - tcl::dict::set spec_merged -optional $specval - } - -ensembleparameter { - #applies to whole arg - not each -type - #review - only leaders? - tcl::dict::set spec_merged $spec $specval - } - -prefix { - #applies to whole arg - not each -type - #for flags/options - tcl::dict::set spec_merged $spec $specval - } - -validationtransform { - #string is dict only 8.7/9+ - if {[llength $specval] % 2} { - error "punk::args::resolve - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" - } - dict for {tk tv} $specval { - switch -- $tk { - -command - -function - -type - -minsize - -maxsize - -range { - } - default { - set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? - error "punk::args::resolve - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" - } - } - } - #TODO! - - } - default { - if {[string match ref-* $spec]} { - #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) - #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. - if {![tcl::dict::exists $refs $specval]} { - puts stderr "punk::args::resolve argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" - } else { - set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" - if {$targetswitch eq "-*"} { - set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id - } else { - if {[tcl::dict::exists $refs $specval $targetswitch]} { - tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] - } else { - puts stderr "punk::args::resolve argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" - } - } - } - } else { - set known_argopts [list -form -type -range -typeranges\ - -default -typedefaults -minsize -maxsize -choices -choicegroups\ - -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted\ - -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - -ensembleparameter\ - ] - error "punk::args::resolve - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" - } - } - } - } ;# end foreach {spec specval} argdef_values - - - if {$is_opt} { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - if {$argname eq "--"} { - #force -type none - in case no -type was specified and @opts -type is some other default such as string - tcl::dict::set spec_merged -type none - } - if {[tcl::dict::get $spec_merged -type] eq "none"} { - dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname] - } - } else { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - tcl::dict::set F $fid ARG_INFO $argname $spec_merged - #review existence of -default overriding -optional - #if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} {} - if {![tcl::dict::get $spec_merged -optional]} { - if {$is_opt} { - set temp_opt_required [dict get $F $fid OPT_REQUIRED] - lappend temp_opt_required $argname - dict set F $fid OPT_REQUIRED $temp_opt_required - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - set temp_leader_required [dict get $F $fid LEADER_REQUIRED] - lappend temp_leader_required $argname - dict set F $fid LEADER_REQUIRED $temp_leader_required - } else { - set temp_val_required [dict get $F $fid VAL_REQUIRED] - lappend temp_val_required $argname - dict set F $fid VAL_REQUIRED $temp_val_required - } - } - } - - - if {[tcl::dict::exists $spec_merged -default]} { - if {$is_opt} { - #tcl::dict::set opt_defaults $argname [tcl::dict::get $spec_merged -default] - tcl::dict::set F $fid OPT_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } else { - #tcl::dict::set val_defaults $argname [tcl::dict::get $spec_merged -default] - tcl::dict::set F $fid VAL_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } - } - } - } ;# end foreach fid record_form_ids - - } ;# end foreach rec $records - - - #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { - # variable id_counter - # set DEF_definition_id "autoid_[incr id_counter]" - #} - - - #now cycle through ALL forms not just form_ids_active (record_form_ids) - dict for {fid formdata} $F { - if {[tcl::dict::get $F $fid OPT_MAX] eq ""} { - if {[llength [tcl::dict::get $F $fid OPT_NAMES]] == 0 && ![tcl::dict::get $F $fid OPT_ANY]} { - tcl::dict::set F $fid OPT_MAX 0 ;#aid in parsing to avoid scanning for opts unnecessarily - #review - when using resolved_def to create a definiation based on another - OPT_MAX may need to be overridden - a bit ugly? - } - } - # REVIEW - #no values specified - we can allow last leader to be multiple - foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { - error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" - } - } - - #todo - disallow any -multiple == true entries if any leaders have -multiple == true? - #(creates parsing ambiguity) - #ambiguity could be resolved if at least one required option/flag eg -- - #ambiguities could theoretically also be resolved with required literals or choices - or even based on argument type - #(overcomplex? todo see if any core/tcllib commands work like that) - - #only allow a single entry within VAL_NAMES to have -multiple == true - #example of command with non-trailing -multiple == true is core command: 'file copy ?-force? ?--? source ?source?... targetDir - set val_multiples 0 - foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { - if {$val_multiples > 0} { - error "bad setting -multiple true on argument spec for value '$valname' in command form:'$fid'. Only a single value argument specification can be marked with -multiple true @id:$DEF_definition_id" - } - incr val_multiples - } - } - - #todo - document that ambiguities in API are likely if both @leaders and @values used - #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) - - - dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata LEADERSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata OPTSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata VALSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - - - - - #todo - precalculate a set of 'arity' entries for each form - #We want a structure for the arg parser to get easy access and make a fast decision on which form applies - #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? - #1) after ms (1 1) - #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? - #3) after cancel id (2 2) - #4) after cancel script ?script...? (2 -1) - #5) after idle script ?script...? (1 -1) - #6) after info ?id? (1 2) - - #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) - - #in the above case we have no unique total_arity - #we would also want to consider values when selecting - #e.g given the invalid command "after cancel" - # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. - - - - set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands - #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use - #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form - #e.g commandline completion could show list of synopsis entries to select from - - set form_info [dict create] - dict for {fid fdict} $F { - dict set form_info $fid {} - dict for {optk optv} $fdict { - if {[string match -* $optk]} { - dict set form_info $fid $optk $optv - } - } - } - - set argdata_dict [tcl::dict::create\ - id $DEF_definition_id\ - cmd_info $cmd_info\ - doc_info $doc_info\ - package_info $package_info\ - seealso_info $seealso_info\ - id_info $id_info\ - FORMS $F\ - form_names [dict keys $F]\ - form_info $form_info\ - ] - - tcl::dict::set argdata_cache $cache_key $argdata_dict - if {$is_dynamic} { - #also cache resolved version - tcl::dict::set argdata_cache [list $optionspecs] $argdata_dict - } - - #tcl::dict::set id_cache_rawdef $DEF_definition_id $args - #puts "xxx:$result" - return $argdata_dict - } - - #return raw definition list as created with 'define' - # - possibly with unresolved dynamic parts - proc raw_def {id} { - variable id_cache_rawdef - set realid [real_id $id] - if {![dict exists $id_cache_rawdef $realid]} { - return "" - } - return [tcl::dict::get $id_cache_rawdef $realid] - } - - - namespace eval argdoc { - variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @formdisplay @seealso @leaders @opts @values leaders opts values} - variable resolved_def_TYPE_CHOICEGROUPS { - directives {@id @package @cmd @ref @doc @formdisplay @seealso} - argumenttypes {leaders opts values} - remaining_defaults {@leaders @opts @values} - } - - lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { - @id -id ::punk::args::resolved_def - @cmd -name punk::args::resolved_def -help\ - "Resolves or retrieves the previously resolved definition and - uses the 'spec' form to build a response in definition format. - - Pulling argument definition data from another function is a form - of tight coupling to the other function that should be done with - care. - - Note that the directives @leaders @opts @values may appear multiple - times in a source definition - applying defaults for arguments that - follow. When retrieving these - there is only a single result for - each that represents the defaults after all have been applied. - When retrieving -types * each of these will be positioned before - the arguments of that type - but this doesn't mean there was a single - leading directive for this argument type in the source definition. - Each argument has already had its complete specification recorded in - its own result. - - When manually specifying -types, the order @leaders then @opts then - @values must be maintained - but if they are placed before their - corresponding arguments, they will not affect the retrieved arguments - as these arguments are already fully spec'd. The defaults from the - source can be removed by adding @leaders, @opts @values to the - -antiglobs list, but again - this won't affect the existing arguments. - Each argument can have members of its spec overridden using the - -override dictionary. - " - @leaders -min 0 -max 0 - @opts - -return -default text -choices {text dict} - -form -default 0 -help\ - "Ordinal index or name of command form" - - #no restriction on number of types/repetitions? - -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} - -antiglobs -default {} -type list -help\ - "Glob patterns for directive or argument/flags to - be suppressed" - -override -type dict -optional 1 -default "" -help\ - "dict of dicts. Key in outer dict is the name of a - directive or an argument. Inner dict is a map of - overrides/additions (- ...) for that line. - " - @values -min 1 -max -1 - id -type string -help\ - "identifer for a punk::args definition - This will usually be a fully-qualifed - path for a command name" - pattern -type string -optional 1 -default * -multiple 1 -help\ - "glob-style patterns for retrieving value or switch - definitions. - - If -type is * and pattern is * the entire definition including - directive lines will be returned in line form. - (directives are lines beginning with - @ e.g @id, @cmd etc) - - if -type is leaders,opts or values matches from that type - will be returned. - - if -type is another directive such as @id, @doc etc the - patterns are ignored. - - " - }]] - } - - - proc resolved_def {args} { - #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. - set opts [dict create\ - -return text\ - -types {}\ - -form 0\ - -antiglobs {}\ - -override {}\ - ] - if {[llength $args] < 1} { - #must have at least id - punk::args::parse $args withid ::punk::args::resolved_def - return - } - set patterns [list] - - #a definition id must not begin with "-" ??? review - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {$a in {-type -types}} { - incr i - dict set opts -types [lindex $args $i] - } elseif {[string match -* $a]} { - incr i - dict set opts $a [lindex $args $i] - } else { - set id [lindex $args $i] - set patterns [lrange $args $i+1 end] - break - } - if {$i == [llength $args]-1} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - if {![llength $patterns]} { - set patterns [list *] - } - dict for {k v} $opts { - #set fullk [tcl::prefix::match -error "" {-return -form -types -antiglobs -override} $k] - switch -- $k { - -return - -form - -types - -antiglobs - -override {} - default { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - } - set typelist [dict get $opts -types] - if {[llength $typelist] == 0} { - set typelist {*} - } - foreach type $typelist { - if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - - - variable id_cache_rawdef - set realid [real_id $id] - if {$realid eq ""} { - return - } - - set deflist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] - - set opt_form [dict get $opts -form] - if {[string is integer -strict $opt_form]} { - set formname [lindex [dict get $specdict form_names] $opt_form] - } else { - set formname $opt_form - } - set opt_override [dict get $opts -override] - set opt_return [dict get $opts -return] - - #set arg_info [dict get $specdict ARG_INFO] - set arg_info [dict get $specdict FORMS $formname ARG_INFO] - set argtypes [dict create leaders leader opts option values value] - - set opt_antiglobs [dict get $opts -antiglobs] - set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] - set suppressed_directives [list] - set suppressed_args [list] - foreach ag $opt_antiglobs { - foreach d $directives { - if {[string match $ag $d]} { - lappend suppressed_directives $d - } - } - foreach argname [dict keys $arg_info] { - if {[string match $ag $argname]} { - lappend suppressed_args $argname - } - } - } - set suppressed_directives [lsort -unique $suppressed_directives] - set suppressed_args [lsort -unique $suppressed_args] - - set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] - - set globbed [list] - foreach pat $patterns { - set matches [dict keys $arg_info $pat] - lappend globbed {*}$matches - } - set globbed [lsort -unique $globbed] - #maintain order of original arg_info keys in globbed results - set ordered_globbed [list] - foreach a [dict keys $arg_info] { - if {$a ni $ordered_globbed && $a in $globbed} { - lappend ordered_globbed $a - } - } - set included_args [punk::args::system::punklib_ldiff $ordered_globbed $suppressed_args] - - set result "" - set resultdict [dict create] - foreach type $typelist { - switch -exact -- $type { - * { - if {"@id" in $included_directives} { - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - foreach directive {@package @cmd @doc @seealso} { - set dshort [string range $directive 1 end] - if {"$directive" in $included_directives} { - if {[dict exists $opt_override $directive]} { - append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict ${dshort}_info]" - dict set resultdict $directive [dict get $specdict ${dshort}_info] - } - } - } - - #todo @formdisplay - - - #output ordered by leader, option, value - foreach pseudodirective {leaders opts values} tp {leader option value} { - set directive "@$pseudodirective" - switch -- $directive { - @leaders {set defaults_key LEADERSPEC_DEFAULTS} - @opts {set defaults_key OPTSPEC_DEFAULTS} - @values {set defaults_key VALSPEC_DEFAULTS} - } - - if {"$directive" in $included_directives} { - if {[dict exists $opt_override "$directive"]} { - append result \n "$directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict FORMS $formname $defaults_key]" - dict set resultdict $directive [dict get $specdict FORMS $formname $defaults_key] - } - } - - if {$pseudodirective in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq $tp} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "\"$m\" [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "\"$m\" $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - - } - @id { - if {"@id" in $included_directives} { - #only a single id record can exist - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - } - @package - @cmd - @doc - @seealso { - if {"$type" in $included_directives} { - set tp [string range $type 1 end] ;# @package -> package - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict ${tp}_info]" - dict set resultdict $type [dict get $specdict ${tp}_info] - } - } - #todo @formdisplay - } - @leaders - @opts - @values { - #these are the active defaults for further arguments - if {"$type" in $included_directives} { - switch -- $type { - @leaders {set defaults_key LEADERSPEC_DEFAULTS} - @opts {set defaults_key OPTSPEC_DEFAULTS} - @values {set defaults_key VALSPEC_DEFAULTS} - } - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS]" - dict set resultdict $type [dict get $specdict FORMS $formname LEADERSPEC_DEFAULTS] - } - } - } - leaders - opts - values { - #pseudo-directives - if {$type in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "\"$m\" [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "\"$m\" $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - default { - } - } - if {$opt_return eq "text"} { - return $result - } else { - return $resultdict - } - } - } - - proc resolved_def_values {id {patternlist *}} { - variable id_cache_rawdef - set realid [real_id $id] - if {$realid ne ""} { - set deflist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [resolve {*}$deflist] - set arg_info [dict get $specdict ARG_INFO] - set valnames [dict get $specdict VAL_NAMES] - set result "" - if {$patternlist eq "*"} { - foreach v $valnames { - set def [dict get $arg_info $v] - set def [dict remove $def -ARGTYPE] - append result \n "$v $def" - } - return $result - } else { - foreach pat $patternlist { - set matches [dict keys $arg_info $pat] - set matches [lsearch -all -inline -glob $valnames $pat] - foreach m $matches { - set def [dict get $arg_info $m] - set def [dict remove $def -ARGTYPE] - append result \n "$m $def" - } - } - return $result - } - } - } - #proc resolved_def_leaders ?? - #proc resolved_def_opts ?? - - proc get_spec {id} { - set deflist [raw_def $id] - if {$deflist eq ""} { - return - } - return [resolve {*}$deflist] - #if {[id_exists $id]} { - # return [resolve {*}[raw_def $id]] - #} - } - proc is_dynamic {id} { - variable id_cache_rawdef - variable rawdef_cache - set deflist [raw_def $id] - if {[dict exists $rawdef_cache $deflist -dynamic]} { - return [dict get $rawdef_cache $deflist -dynamic] - } - return [rawdef_is_dynamic $deflist] - #@dynamic only has meaning as 1st element of a def in the deflist - } - - #@id must be within first 4 lines of a block - or assign auto - #review - @dynamic block where -id not explicitly set? - disallow? - proc rawdef_id {rawdef} { - set id "" - foreach d $rawdef { - foreach ln [lrange [split $d \n] 0 4] { - if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { - if {$firstword eq "@id"} { - if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { - set id [dict get $rest -id] - break - } - } - } - } - if {$id ne ""} { - break - } - } - if {$id eq "" || [string tolower $id] eq "auto"} { - variable id_counter - set id "autoid_[incr id_counter]" - } - #puts "==>id: $id" - return $id - } - #test the rawdef for @dynamic directive - proc rawdef_is_dynamic {rawdef} { - #temporary - old way - set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] - if {$flagged_dynamic} { - return true - } - foreach d $rawdef { - if {[regexp {\s*(\S+)} $d _match firstword]} { - if {$firstword eq "@dynamic"} { - return true - } - } - } - return false - } - - variable aliases - set aliases [dict create] - - lappend PUNKARGS [list { - @id -id ::punk::args::get_ids - @cmd -name punk::args::get_ids -help\ - "return list of ids for argument definitions" - @values -min 0 -max 1 - match -default * -help\ - "exact id or glob pattern for ids" - }] - proc get_ids {{match *}} { - variable id_cache_rawdef - variable aliases - return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] - } - - #we don't automatically test for (autodef)$id - only direct ids and aliases - proc id_exists {id} { - variable aliases - if {[tcl::dict::exists $aliases $id]} { - return 1 - } - variable id_cache_rawdef - tcl::dict::exists $id_cache_rawdef $id - } - proc set_alias {alias id} { - variable aliases - dict set aliases $alias $id - } - proc unset_alias {alias} { - variable aliases - dict unset aliases $alias - } - proc get_alias {alias} { - variable aliases - if {[dict exists $aliases $alias]} { - return [tcl::dict::get $aliases $alias] - } - } - - proc real_id {id} { - variable id_cache_rawdef - variable aliases - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } else { - set check_updates [list [namespace qualifiers $id]] - #puts stderr "---->real_id '$id' update_definitions $check_updates" - if {![llength [update_definitions $check_updates]]} { - #nothing new loaded - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } else { - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } - } - } - - proc status {} { - upvar ::punk::args::register::NAMESPACES registered - upvar ::punk::args::register::loaded_packages loaded_packages - upvar ::punk::args::register::loaded_info loaded_info - upvar ::punk::args::register::scanned_packages scanned_packages - upvar ::punk::args::register::scanned_info scanned_info - set result "" - # [format %-${w0}s $idtail] - set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] - append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n - set width_c2 [string length "Scanned_ids"] - set width_c3 [string length "Scantime_us"] - set width_c4 [string length "Loaded_defs"] - set width_c5 [string length "Loadtime_us"] - set count_unloaded 0 - set count_loaded 0 - foreach ns $registered { - if {$ns in $scanned_packages} { - set ids [dict get $scanned_info $ns idcount] - set scan_us [dict get $scanned_info $ns time] - } else { - set ids "" - set scan_us "" - } - if {$ns in $loaded_packages} { - incr count_loaded - set ldefs [dict get $loaded_info $ns defcount] - set load_us [dict get $loaded_info $ns time] - } else { - incr count_unloaded - set ldefs "" - set load_us "" - } - append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n - } - append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" - return $result - } - - #scanned_packages (list) - #namespace_docpackages (dict) - proc update_definitions {{nslist *}} { - #puts "----> update_definitions '$nslist'" - if {[set gposn [lsearch $nslist {}]] >= 0} { - lset nslist $gposn :: - } - upvar ::punk::args::register::NAMESPACES registered ;#list - upvar ::punk::args::register::loaded_packages loaded_packages ;#list - upvar ::punk::args::register::loaded_info loaded_info ;#dict - upvar ::punk::args::register::scanned_packages scanned_packages ;#list - upvar ::punk::args::register::scanned_info scanned_info ;#dict - upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict - - - #puts stderr "-->update_definitions '$nslist'" - #needs to run quickly - especially when no package namespaces to be scanned for argdefs - #e.g - gets called for each subcommand of an ensemble (could be many) - # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. - #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. - # -- --- --- --- --- --- - # common-case fast-path - - if {[llength $loaded_packages] == [llength $registered]} { - #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. - #assert - if all are registered - then all have been scanned - return {} - } - # -- --- --- --- --- --- - - set unscanned [punklib_ldiff $registered $scanned_packages] - if {[llength $unscanned]} { - foreach pkgns $unscanned { - set idcount 0 - set ts_start [clock microseconds] - if {[info exists ${pkgns}::PUNKARGS]} { - set seen_documentedns [list] ;#seen per pkgns - foreach definitionlist [set ${pkgns}::PUNKARGS] { - #namespace eval $evalns [list punk::args::define {*}$definitionlist] - set id [rawdef_id $definitionlist] - if {[string match autoid_* $id]} { - puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" - puts stderr "definition:\n" - foreach d $definitionlist { - set out "" - foreach ln [split $d \n] { - append out " " $ln \n - } - puts $out - } - continue - } - #todo - detect duplicate ids (last will silently win.. should be reported somewhere) - incr idcount - set documentedns [namespace qualifiers $id] - if {$documentedns eq ""} {set documentedns ::} - if {$documentedns ni $seen_documentedns} { - #don't add own ns as a key in namespace_docpackages - if {$documentedns ne $pkgns} { - dict lappend namespace_docpackages $documentedns $pkgns - } - lappend seen_documentedns $documentedns - } - } - } - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - dict set scanned_info $pkgns [dict create time $diff idcount $idcount] - #we count it as scanned even if PUNKARGS didn't exist - #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) - lappend scanned_packages $pkgns - } - } - - - - if {"*" in $nslist} { - set needed [punklib_ldiff $registered $loaded_packages] - } else { - set needed [list] - foreach pkgns $nslist { - if {![string match ::* $pkgns]} { - puts stderr "warning: update_definitions received unqualified ns: $pkgns" - set pkgns ::$pkgns - } - if {$pkgns in $registered && $pkgns ni $loaded_packages} { - lappend needed $pkgns - } - #argdoc sub namespace is a standard place to put defs that match the namespace below - #(generally the PUNKARGS in a namespace should apply to own ns) - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { - lappend needed $docns - } - } - if {[dict exists $namespace_docpackages $pkgns]} { - #this namespace has other argdef sources - foreach docns [dict get $namespace_docpackages $pkgns] { - if {$docns ni $loaded_packages} { - lappend needed $docns - } - } - } - } - } - - - - set newloaded [list] - foreach pkgns $needed { - #puts stderr "update_definitions Loading: $pkgns" - set ts_start [clock microseconds] - set def_count 0 - if {![catch { - if {[info exists ${pkgns}::PUNKARGS]} { - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - namespace eval ${pkgns}::argdoc { - set epath [namespace path] - set pkgns [namespace parent] - if {$pkgns ni $epath} { - namespace path [list {*}$epath $pkgns] ;#add to tail - } - - } - set evalns $docns - } else { - set evalns $pkgns - } - foreach definitionlist [set ${pkgns}::PUNKARGS] { - namespace eval $evalns [list punk::args::define {*}$definitionlist] - incr def_count - } - } - - #process list of 2-element lists - if {[info exists ${pkgns}::PUNKARGS_aliases]} { - foreach adef [set ${pkgns}::PUNKARGS_aliases] { - punk::args::set_alias {*}$adef - } - } - } errMsg]} { - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - lappend loaded_packages $pkgns - lappend newloaded $pkgns - dict set loaded_info $pkgns [dict create time $diff defcount $def_count] - } else { - puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" - } - } - return $newloaded - } - - #for use within get_dict only - #This mechanism gets less-than-useful results for oo methods - #e.g {$obj} - proc Get_caller {} { - #set call_level -3 ;#for get_dict call - set call_level -4 - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - #puts "-->$cmdinfo" - #puts "-->[tcl::info::frame -3]" - while {[string last \n $cmdinfo] >= 1} { - #looks like a script - haven't gone up far enough? - #(e.g patternpunk oo system: >punk . poses -invalidoption) - incr call_level -1 - if {[catch { - set nextup [tcl::info::frame $call_level] - } ]} { - break - } - set cmdinfo [tcl::dict::get $nextup cmd] - set caller [regexp -inline {\S+} $cmdinfo] - if {[interp alias {} $caller] ne ""} { - #puts "found alias for caller $caller to [interp alias {} $caller]" - #see if we can go further - incr call_level -1 - if {[catch { - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - } errM ]} { - puts "err: $errM" - break - } - } - } - set caller [regexp -inline {\S+} $cmdinfo] - if {$caller eq "namespace"} { - # review - message? - set cmdinfo "Get_caller (punk::args::get_dict?) called from namespace" - } - return $cmdinfo - } - - - # -------------------------------------- - #test of Get_caller - lappend PUNKARGS [list { - @id -id ::punk::args::test1 - @values -min 0 -max 0 - }] - proc test_get_dict {args} { - punk::args::get_dict [punk::args::raw_def ::punk::args::test1] $args - } - proc test_get_by_id {args} { - punk::args::get_by_id ::punk::args::test1 $args - } - #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. - proc test_callers {args} { - if {![llength $args]} { - puts "these test functions accept no arguments" - puts "Call with arg(s) to compare error output" - } - - if {[catch {test_get_dict {*}$args} errM]} { - puts $errM - } - puts "------------" - if {[catch {test_get_by_id {*}$args} errM]} { - puts $errM - } - return done - } - # -------------------------------------- - - set map "" - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::arg_error - @cmd -name punk::args::arg_error -help\ - "Generates a table (by default) of usage information for a command. - A trie system is used to create highlighted prefixes for command - switches and for subcommands or argument/switch values that accept - a defined set of choices. These prefixes match the mechanism used - to validate arguments (based on tcl::prefix::match). - - This function is called during the argument parsing process - (if the definition is not only being used for documentation) - It is also called by punk::args::usage which is in turn - called by the punk::ns introspection facilities which creates - on the fly definitions for some commands such as ensembles and - oo objects where a manually defined one isn't present. - " - @leaders -min 2 -max 2 - msg -type string -help\ - "Error message to display immediately prior to usage table. - May be empty string to just display usage. - " - spec_dict -type dict -help\ - "Dictionary of argument specifications. - This is the internal format parsed from - the textual definition. It contains the data - organised/optimised to allow the final arg - parser/validator to make decisions. - " - @opts - -badarg -type string -help\ - "name of an argument to highlight" - -parsedargs -type dict -help\ - "Result of successful punk::pargs::parse - (currently only looks at 'received')" - -aserror -type boolean -help\ - "If true, the usage table is raised as an error message, - otherwise it is returned as a value." - -return -choices {string table tableobject} -choicelabels { - string "no table layout" - tableobject "table object cmd" - table "full table layout" - } - -scheme -default error -choices {nocolour info error} - -form -default 0 -help\ - "Ordinal index or name of command form" - }] ] - - if {[catch {package require punk::ansi}]} { - proc punk::args::a {args} {} - proc punk::args::a+ {args} {} - } else { - namespace eval ::punk::args { - namespace import ::punk::ansi::a ::punk::ansi::a+ - } - } - variable arg_error_CLR - array set arg_error_CLR {} - set arg_error_CLR(errormsg) [a+ brightred] - set arg_error_CLR(title) "" - set arg_error_CLR(check) [a+ brightgreen] - set arg_error_CLR(solo) [a+ brightcyan] - set arg_error_CLR(choiceprefix) [a+ underline] - set arg_error_CLR(badarg) [a+ brightred] - set arg_error_CLR(goodarg) [a+ green strike] - set arg_error_CLR(goodchoice) [a+ reverse] - set arg_error_CLR(linebase_header) [a+ white] - set arg_error_CLR(cmdname) [a+ brightwhite] - set arg_error_CLR(groupname) [a+ bold] - set arg_error_CLR(ansiborder) [a+ bold] - set arg_error_CLR(ansibase_header) [a+ bold] - set arg_error_CLR(ansibase_body) [a+ white] - variable arg_error_CLR_nocolour - array set arg_error_CLR_nocolour {} - set arg_error_CLR_nocolour(errormsg) [a+ bold] - set arg_error_CLR_nocolour(title) [a+ bold] - set arg_error_CLR_nocolour(check) "" - set arg_error_CLR_nocolour(solo) "" - set arg_error_CLR_nocolour(badarg) [a+ reverse] ;#? experiment - set arg_error_CLR_nocolour(goodarg) [a+ strike] - set arg_error_CLR_nocolour(cmdname) [a+ bold] - set arg_error_CLR_nocolour(linebase_header) "" - set arg_error_CLR_nocolour(linebase) "" - set arg_error_CLR_nocolour(ansibase_body) "" - variable arg_error_CLR_info - array set arg_error_CLR_info {} - set arg_error_CLR_info(errormsg) [a+ brightred bold] - set arg_error_CLR_info(title) [a+ brightyellow bold] - set arg_error_CLR_info(check) [a+ brightgreen bold] - set arg_error_CLR_info(choiceprefix) [a+ brightgreen bold] - set arg_error_CLR_info(groupname) [a+ cyan bold] - set arg_error_CLR_info(ansiborder) [a+ brightcyan bold] - set arg_error_CLR_info(ansibase_header) [a+ cyan] - set arg_error_CLR_info(ansibase_body) [a+ white] - variable arg_error_CLR_error - array set arg_error_CLR_error {} - set arg_error_CLR_error(errormsg) [a+ brightred bold] - set arg_error_CLR_error(title) [a+ brightcyan bold] - set arg_error_CLR_error(check) [a+ brightgreen bold] - set arg_error_CLR_error(choiceprefix) [a+ brightgreen bold] - set arg_error_CLR_error(groupname) [a+ cyan bold] - set arg_error_CLR_error(ansiborder) [a+ brightyellow bold] - set arg_error_CLR_error(ansibase_header) [a+ yellow] - set arg_error_CLR_error(ansibase_body) [a+ white] - - - #bas ic recursion blocker - variable arg_error_isrunning 0 - proc arg_error {msg spec_dict args} { - #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. - #accept an option here so that we can still use full output for usage requests. - #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args - #Development/experimentation may be done with full table-based error reporting - but for production release it - #may be desirable to reduce overhead on catches. - #consider per-namespace or namespace-tree configurability. - #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due - #to resource availability etc - so the slower error generation time may not always be a problem. - #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling - #code which has no use for the enhanced error info. - #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. - #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system - #todo - #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error - #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) - - #todo - document unnamed leaders and unnamed values where -min and/or -max specified - #e.g punk::args::parse {} withdef {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} - #only |?-x?|string|... is shown in the output table. - #should be something like: - # |arg | - # |?-x? | - # |arg | - # |?arg...?| - # Where/how to specify counts? - #also.. - # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? - # - - - #limit colours to standard 16 so that themes can apply to help output - variable arg_error_isrunning - if {$arg_error_isrunning} { - error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" - } - - if {[llength $args] %2 != 0} { - error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" - } - - set arg_error_isrunning 1 - - set badarg "" - set parsedargs [dict create] ;#dict with keys: leaders,opts,values,received,solos,multis (as from punk::args::parse) - set goodargs [list] - set returntype table ;#table as string - set as_error 1 ;#usual case is to raise an error - set scheme error - set form 0 - dict for {k v} $args { - set fullk [tcl::prefix::match -error "" {-badarg -parsedargs -aserror -return -scheme -form} $k] - switch -- $fullk { - -badarg { - set badarg $v - } - -parsedargs { - #todo? - dict for {set setinfo} $v { - switch -- $set { - received { - foreach {r rpos} $setinfo { - if {$r ni $goodargs} { - lappend goodargs $r - } - } - } - } - } - set parsedargs $v - } - -aserror { - if {![string is boolean -strict $v]} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" - } - set as_error $v - } - -scheme { - set scheme $v - } - -return { - if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" - } - set returntype $v - } - -form { - set form $v - } - default { - set arg_error_isrunning 0 - error "arg_error invalid option $k. Known_options: -badarg -parsedargs -aserror -scheme -return -form" - } - } - } - #todo - scheme - use config and iterm toml definitions etc - switch -- $scheme { - "" - -nocolor - -nocolour { - set scheme nocolour - } - info - error {} - default { - set scheme na - } - } - set formnames [dict get $spec_dict form_names] - if {[string is integer -strict $form]} { - if {$form < 0 || $form > [llength $formnames]-1} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" - } - set selected_forms [list [lindex $formnames $form]] - } else { - if {$form eq "*"} { - set selected_forms $formnames - } else { - if {$form in $formnames} { - set selected_forms [list $form] - } else { - set arg_error_isrunning 0 - error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" - } - } - } - - - #hack some basics for now. - #for coloured schemes - use bold as well as brightcolour in case colour off. - upvar ::punk::args::arg_error_CLR CLR - - switch -- $scheme { - nocolour { - variable arg_error_CLR_nocolour - array set CLR [array get arg_error_CLR_nocolour - } - info { - variable arg_error_CLR_info - array set CLR [array get arg_error_CLR_info] - } - error { - variable arg_error_CLR_error - array set CLR [array get arg_error_CLR_error] - } - na { - } - } - - - #set RST [a] - set RST "\x1b\[m" - set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. - - #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error - #e.g list_as_table - - # use basic colours here to support terminals without extended colours - #todo - add checks column (e.g -minsize -maxsize) - set errmsg $msg - if {![catch {package require textblock}]} { - set has_textblock 1 - } else { - set has_textblock 0 - #couldn't load textblock package - #just return the original errmsg without formatting - } - set use_table 0 - if {$has_textblock && $returntype in {table tableobject}} { - set use_table 1 - } - set errlines [list] ;#for non-textblock output - if {[catch { - if {$use_table} { - append errmsg \n - } else { - if {($returntype in {table tableobject}) && !$has_textblock} { - append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n - } else { - append errmsg \n - } - } - set cmdname [Dict_getdef $spec_dict cmd_info -name ""] - set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] - - set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] - set docurl [Dict_getdef $spec_dict doc_info -url ""] - - #set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] - #set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] - #if {"$argdisplay_header$argdisplay_body" eq ""} { - # set is_custom_argdisplay 0 - #} else { - # set is_custom_argdisplay 1 - #} - - #temp - TODO - set argdisplay_header "" - set argdisplay_body "" - set is_custom_argdisplay 0 - - - set blank_header_col [list] - if {$cmdname ne ""} { - lappend blank_header_col "" - set cmdname_display $CLR(cmdname)$cmdname$RST - } else { - set cmdname_display "" - } - if {$cmdhelp ne ""} { - lappend blank_header_col "" - #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] - set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] - } else { - set cmdhelp_display "" - } - if {$docurl ne ""} { - lappend blank_header_col "" - set docurl_display [a+ white]$docurl$RST - } else { - set docurl_display "" - } - #synopsis - set synopsis "" - set form_info [dict get $spec_dict form_info] - dict for {fid finfo} $form_info { - set form_synopsis [Dict_getdef $finfo -synopsis ""] - if {$form_synopsis eq ""} { - #todo - set form_synopsis [punk::args::synopsis -form $fid [dict get $spec_dict id]] - if {[string length $form_synopsis] > 90} { - # - set form_synopsis [punk::args::synopsis -return summary -form $fid [dict get $spec_dict id]] - } - if {[string match (autodef)* $form_synopsis]} { - set form_synopsis [string range $form_synopsis 9 end] - } - } - if {$fid in $selected_forms} { - set form_synopsis [punk::ansi::a+ underline]$form_synopsis[punk::ansi::a+ nounderline] - } - append synopsis $form_synopsis \n - } - if {$synopsis ne ""} { - set synopsis [string trimright $synopsis \n] - lappend blank_header_col "" - } - - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - if {$use_table} { - set t [textblock::class::table new "$CLR(title)Usage$RST"] - $t add_column -headers $blank_header_col -minwidth 3 - $t add_column -headers $blank_header_col - - if {!$is_custom_argdisplay} { - lappend blank_header_col "" - #spanned columns in default argdisplay area - $t add_column -headers $blank_header_col ;#Default - $t add_column -headers $blank_header_col ;#Multi - $t add_column -headers $blank_header_col ;#Help - set arg_colspans {1 4 0 0 0} - } else { - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - set arg_colspans {1 1} - } - } - set h 0 - if {$cmdname ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] - } else { - lappend errlines "COMMAND: $cmdname_display" - } - incr h - } - if {$cmdhelp ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] - } else { - lappend errlines "Description: $cmdhelp_display" - } - incr h - } - if {$docurl ne ""} { - if {![catch {package require punk::ansi}]} { - set docurl [punk::ansi::hyperlink $docurl] - } - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] - } else { - lappend errlines "$docname $docurl_display" - } - incr h - } - if {$synopsis ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Synopsis: [punk::ansi::ansiwrap brightwhite $synopsis]] - } else { - #todo - lappend errlines "Synopsis:\n$synopsis" - } - incr h - } - - - if {$use_table} { - if {$is_custom_argdisplay} { - if {$argdisplay_header ne ""} { - $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] - } - } else { - $t configure_header $h -values {Arg Type Default Multi Help} - } - } else { - lappend errlines " --ARGUMENTS-- " - } - - if {$is_custom_argdisplay} { - if {$use_table} { - #using overall container table - #header already added - #TODO - review textblock::table features - #we can't currently span columns within the table body. - #This feature could allow hidden data columns (and sort on hidden col?) - #potentially require coordination with header colspans? - $t add_row [list "" $argdisplay_body] - } else { - if {$argdisplay_header ne ""} { - lappend errlines $argdisplay_header - } - lappend errlines {*}$argdisplay_body - } - } else { - - #set A_DEFAULT [a+ brightwhite Brightgreen] - set A_DEFAULT "" - set A_BADARG $CLR(badarg) - set A_GOODARG $CLR(goodarg) - set A_GOODCHOICE $CLR(goodchoice) - set greencheck $CLR(check)\u2713$RST ;#green tick - set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply - if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { - #A_PREFIX can resolve to empty string if colour off - #we then want to display underline instead - set A_PREFIX [a+ underline] - set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space - } else { - set A_PREFIXEND $RST - } - - #TODO - foreach fid - set fid [lindex $selected_forms 0] - set form_dict [dict get $spec_dict FORMS $fid] - - set opt_names [list] - set opt_names_display [list] - set lookup_optset [dict create] - if {[llength [dict get $form_dict OPT_NAMES]]} { - set all_opts [list] - foreach optset [dict get $form_dict OPT_NAMES] { - #e.g1 "-alias1|-realname" - #e.g2 "-f|--filename" (fossil longopt style) - #e.g3 "-f|--filename=" (gnu longopt style) - set optmembers [split $optset |] - lappend all_opts {*}$optmembers - foreach o $optmembers { - dict set lookup_optset $o $optset - #goodargs - } - } - set full_goodargs [list] - #goodargs may have simplified entries for received opts of form -alias1|-alias2|-realname - #map -realname to full argname - foreach g $goodargs { - if {[string match -* $g] && [dict exists $lookup_optset $g]} { - lappend full_goodargs [dict get $lookup_optset $g] - } else { - lappend full_goodargs $g - } - } - set goodargs $full_goodargs - if {![catch {package require punk::trie}]} { - #todo - reservelist for future options - or just to affect the prefix calculation - # (similar to -choiceprefixreservelist) - - set trie [punk::trie::trieclass new {*}$all_opts --] - set idents [dict get [$trie shortest_idents ""] scanned] - #todo - check opt_prefixdeny - - $trie destroy - foreach optset [dict get $form_dict OPT_NAMES] { - set arginfo [dict get $form_dict ARG_INFO $optset] - if {[dict get $arginfo -prefix]} { - set opt_members [split $optset |] - set odisplay [list] - foreach opt $opt_members { - set id [dict get $idents $opt] - #REVIEW - if {$id eq $opt} { - set prefix $opt - set tail "" - } else { - set idlen [string length $id] - set prefix [string range $opt 0 $idlen-1] - set tail [string range $opt $idlen end] - } - lappend odisplay $A_PREFIX$prefix$A_PREFIXEND$tail - } - #lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail - lappend opt_names_display [join $odisplay |] - } else { - lappend opt_names_display $optset - } - #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] - lappend opt_names $optset - } - } else { - set opt_names [dict get $form_dict OPT_NAMES] - set opt_names_display $opt_names - } - } - set leading_val_names [dict get $form_dict LEADER_NAMES] - set trailing_val_names [dict get $form_dict VAL_NAMES] - - #dict for {argname info} [tcl::dict::get $form_dict arg_info] { - # if {![string match -* $argname]} { - # lappend leading_val_names [lpop trailing_val_names 0] - # } else { - # break - # } - #} - #if {![llength $leading_val_names] && ![llength $opt_names]} { - # #all vals were actually trailing - no opts - # set trailing_val_names $leading_val_names - # set leading_val_names {} - #} - set leading_val_names_display $leading_val_names - set trailing_val_names_display $trailing_val_names - #puts "--> parsedargs: $parsedargs" - set parsed_leaders [Dict_getdef $parsedargs leaders {}] - set parsed_opts [Dict_getdef $parsedargs opts {}] - set parsed_values [Dict_getdef $parsedargs values {}] - - #display options first then values - foreach argumentclassinfo [list [list leaders $leading_val_names_display $leading_val_names $parsed_leaders] [list opts $opt_names_display $opt_names $parsed_opts] [list values $trailing_val_names_display $trailing_val_names $parsed_values]] { - lassign $argumentclassinfo argumentclass argnames_display argnames parsedvalues - - foreach argshow $argnames_display arg $argnames { - set arginfo [dict get $form_dict ARG_INFO $arg] - if {[dict exists $arginfo -default]} { - set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" - } else { - set default "" - } - set help [Dict_getdef $arginfo -help ""] - set allchoices_originalcase [list] - set choices [Dict_getdef $arginfo -choices {}] - set choicegroups [Dict_getdef $arginfo -choicegroups {}] - set choicemultiple [dict get $arginfo -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] - set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] - set choiceprefixreservelist [Dict_getdef $arginfo -choiceprefixreservelist {}] ;#names used to calc prefix - but not available as actual choice. - if {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - set is_multiple 1 - } else { - set multiple "" - set is_multiple 0 - } - if {[dict exists $choicegroups ""]} { - dict lappend choicegroups "" {*}$choices - } else { - set choicegroups [dict merge [dict create "" $choices] $choicegroups] - } - #review - does choiceprefixdenylist need to be added? - dict for {groupname clist} $choicegroups { - lappend allchoices_originalcase {*}$clist - } - set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] - - if {$has_choices} { - if {$help ne ""} {append help \n} - if {[dict get $arginfo -nocase]} { - set casemsg " (case insensitive)" - set allchoices_prefixcalc [list {*}[string tolower $allchoices_originalcase] {*}$choiceprefixreservelist] - } else { - set casemsg " (case sensitive)" - set allchoices_prefixcalc [list {*}$allchoices_originalcase {*}$choiceprefixreservelist] - } - if {[dict get $arginfo -choiceprefix]} { - set prefixmsg " (choice prefix allowed)" - } else { - set prefixmsg "" - } - set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] - set choiceinfodict [Dict_getdef $arginfo -choiceinfo {}] - set formattedchoices [dict create] ;#use dict rather than array to preserve order - append help " Choices$prefixmsg$casemsg" - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - if {$choicemultiple_max == -1} { - append help \n " The value can be a list of $choicemultiple_min or more of these choices" - } else { - if {$choicemultiple_min eq $choicemultiple_max} { - append help \n " The value must be a list of $choicemultiple_min of these choices" - } else { - append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" - } - } - } - if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c [join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } else { - #set formattedchoices $choicegroups - #set formattedchoices [dict get $arginfo -choices] - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c [join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } - } else { - if {[catch { - set trie [punk::trie::trieclass new {*}$allchoices_prefixcalc] - set idents [dict get [$trie shortest_idents ""] scanned] - if {[dict get $arginfo -nocase]} { - #idents were calculated on lcase - remap keys in idents to original casing - set actual_idents $idents - foreach ch $allchoices_originalcase { - if {![dict exists $idents $ch]} { - #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting - #The actual testing is done in get_dict - dict set actual_idents $ch [dict get $idents [string tolower $ch]] - } - } - set idents $actual_idents - #puts "-----" - #puts "idents $idents" - } - - $trie destroy - dict for {groupname clist} $choicegroups { - foreach c $clist { - if {$c in $choiceprefixdenylist} { - set shortestid $c - } else { - set shortestid [dict get $idents $c] - } - if {$shortestid eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $shortestid] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set mk " [join $markers {}]" - } else { - set mk "" - } - set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]$mk" - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - #puts "-- parsed:$parsedvalues arg:$arg c:$c" - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } errM]} { - #this failure can happen if -nocase is true and there are ambiguous entries - #e.g -nocase 1 -choices {x X} - puts stderr "prefix marking failed\n$errM" - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c [join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } else { - #set formattedchoices $choicegroups - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c[join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } - - } - } - set choicetable_objects [list] - set choicetable_footers [dict create] - dict for {groupname formatted} $formattedchoices { - set numcols $choicecolumns ;#todo - dynamic? - if {[llength $formatted] < $numcols} { - #don't show blank cells if single line of results - set numcols [llength $formatted] - } - if {$numcols > 0} { - if {$use_table} { - #risk of recursing - #TODO -title directly in list_as_table - set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] - lappend choicetable_objects $choicetableobj - $choicetableobj configure -title $CLR(groupname)$groupname - #append help \n[textblock::join -- " " [$choicetableobj print]] - } else { - if {$groupname ne ""} { - append help \n \n "$CLR(groupname)Group: $groupname$RST" - } else { - append help \n - } - append help \n [join $formatted \n] - } - } else { - #we were given an empty set of choices. - #probably an error in the definition - but could happen if dynamically generated. - #(e.g ensemble where unknown mechanism is used for subcommands?) - #better to just display that there were none rather than totally break the usage output. - if {$usetable} { - #these will be displayed after all table entries - if {$groupname eq ""} { - dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" - } else { - dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" - } - } else { - if {$groupname eq ""} { - append help \n " " $CLR(errormsg)(no choices defined)$RST - } else { - append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST - } - } - } - } - set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width - foreach obj $choicetable_objects { - dict lappend twidths_by_colcount [$obj column_count] [$obj width] - } - foreach obj $choicetable_objects { - set cols [$obj column_count] - set widths [dict get $twidths_by_colcount $cols] - set max [tcl::mathfunc::max {*}$widths] - $obj configure -minwidth $max ;#expand smaller ones - set i 0 - while {$i < $cols} { - #keep text aligned left on expanded tables - $obj configure_column $i -blockalign left - incr i - } - - append help \n[textblock::join -- " " [$obj print]] - #set ansititle [dict get [$obj configure -title] value] - $obj destroy - } - if {[dict size $choicetable_footers]} { - foreach groupname [dict keys $formattedchoices] { - if {[dict exists $choicetable_footers $groupname]} { - append help \n [dict get $choicetable_footers $groupname] - } - } - } - - #review. use -type to restrict additional choices - may be different to values in the -choices - if {![dict get $arginfo -choicerestricted]} { - #when -choicemultiple - the -type refers to each selection - if {[dict get $arginfo -type] eq "string"} { - append help "\n (values not in defined choices are allowed)" - } else { - append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" - } - } - } - if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { - if {$is_multiple} { - set argshow "?${argshow}...?" - } else { - set argshow "?${argshow}?" - } - } else { - if {$is_multiple} { - set argshow "${argshow}..." - } - } - set typeshow [dict get $arginfo -type] - if {$typeshow eq "none"} { - set typeshow "$typeshow $soloflag" - } - if {[dict exists $arginfo -minsize]} { - append typeshow \n "-minsize [dict get $arginfo -minsize]" - } - if {[dict exists $arginfo -maxsize]} { - append typeshow \n "-maxsize [dict get $arginfo -maxsize]" - } - if {[dict exists $arginfo -typeranges]} { - set ranges [dict get $arginfo -typeranges] - if {[llength $ranges] == 1} { - append typeshow \n "-range [lindex [dict get $arginfo -typeranges] 0]" - } else { - append typeshow \n "-ranges" - foreach r $ranges { - append typeshow " {$r}" - } - } - } - - if {$use_table} { - $t add_row [list $argshow $typeshow $default $multiple $help] - if {$arg eq $badarg} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG - } elseif {$arg in $goodargs} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $A_GOODARG - } - } else { - #review - formatting will be all over the shop due to newlines in typesshow, help - set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" - if {$arg eq $badarg} { - set arghelp [punk::ansi::ansiwrap -rawansi $A_BADARG $arghelp] - } elseif {$arg in $goodargs} { - set arghelp [punk::ansi::ansiwrap -rawansi $A_GOODARG $arghelp] - } - foreach ln [split $help \n] { - append arghelp " $ln" \n - } - lappend errlines $arghelp - } - } - - # ------------------------------------------------------------------------------------------------------- - # if the argument class can accept unnamed arguments (or if opts accepts unspecified flags) - display an indication - # ------------------------------------------------------------------------------------------------------- - switch -- $argumentclass { - leaders - values { - if {$argumentclass eq "leaders"} { - set class_unnamed LEADER_UNNAMED - set class_max LEADER_MAX - set class_required LEADER_REQUIRED - set class_directive_defaults LEADERSPEC_DEFAULTS - } else { - set class_unnamed VAL_UNNAMED - set class_max VAL_MAX - set class_required VAL_REQUIRED - set class_directive_defaults VALSPEC_DEFAULTS - } - if {[dict get $form_dict $class_unnamed]} { - set valmax [dict get $form_dict $class_max] - #set valmin [dict get $form_dict VAL_MIN] - if {$valmax eq ""} { - set valmax -1 - } - if {$valmax == -1} { - set possible_unnamed -1 - } else { - set possible_unnamed [expr {$valmax - [llength [dict get $form_dict $class_required]]}] - if {$possible_unnamed < 0} { - set possible_unnamed 0 - } - } - if {$possible_unnamed == -1 || $possible_unnamed > 0} { - #Note 'multiple' is always empty here as each unnamed is assigned to its own positional index - if {$possible_unnamed == 1} { - set argshow ?? - } else { - set argshow ?...? - } - set tp [dict get $form_dict $class_directive_defaults -type] - if {[dict exists $form_dict $class_directive_defaults -default]} { - set default [dict get $form_dict $class_directive_defaults -default] - } else { - set default "" - } - if {$use_table} { - $t add_row [list "$argshow" $tp $default "" ""] - } else { - set arghelp "[a+ bold]$argshow$RST TYPE:$tp DEFAULT:$default\n" - lappend errlines $arghelp - } - } - } - } - opts { - #display row to indicate if -any|-arbitrary true - - #review OPTSPEC_DEFAULTS -multiple ? - if {[dict get $form_dict OPT_ANY]} { - set argshow "?...?" - set tp [dict get $form_dict OPTSPEC_DEFAULTS -type] - if {[dict exists $form_dict OPTSPEC_DEFAULTS -default]} { - set default [dict get $form_dict OPTSPEC_DEFAULTS -default] - } else { - set default "" - } - if {$use_table} { - $t add_row [list "$argshow" $tp $default "" ""] - } else { - set arghelp "[a+ bold]$argshow$RST TYPE:$tp DEFAULT:$default\n" - lappend errlines $arghelp - } - } - } - } - - } ;#end foreach argumentclass - } ;#end is_custom_argdisplay - - if {$use_table} { - $t configure -show_hseps 0\ - -show_header 1\ - -ansibase_body $CLR(ansibase_body)\ - -ansibase_header $CLR(ansibase_header)\ - -ansiborder_header $CLR(ansiborder)\ - -ansiborder_body $CLR(ansiborder) - - $t configure -maxwidth 80 ;#review - if {$returntype ne "tableobject"} { - append errmsg [$t print] - #returntype of table means just the text of the table - $t destroy - } - } else { - append errmsg [join $errlines \n] - } - } errM]} { - append errmsg \n - append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n - append errmsg "$errM" \n - append errmsg "$::errorInfo" - catch {$t destroy} - - } - set arg_error_isrunning 0 - if {$use_table} { - #assert returntype is one of table, tableobject - set result $errmsg ;#default if for some reason table couldn't be used - if {$returntype eq "tableobject"} { - if {[info object isa object $t]} { - set result $t - } - } - } else { - set result $errmsg - } - if {$as_error} { - #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. - #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) - uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] - } else { - return $result - } - } - - - lappend PUNKARGS [list { - @dynamic - @id -id ::punk::args::usage - @cmd -name punk::args::usage -help\ - "Return usage information for a command identified by an id. - - This will only work for commands where a punk::args definition exists - for the command and an id has been defined for it. The id for custom - help for a command should match the fully qualified name of the command. - - Many commands (such as ensembles and oo objects) may have argument - documentation generated dynamically and may not yet have an id. - IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. - - Generally punk::ns::arginfo (aliased as i in the punk shell) should - be used in preference - as it will search for a documentation - mechanism and call punk::args::usage as necessary. - " - -return -default table -choices {string table tableobject} - }\ - {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}}\ - {${[punk::args::resolved_def -types opts ::punk::args::resolved_def -form]}}\ - { - - @values -min 0 -max 1 - id -help\ - "Exact id. - Will usually match the command name" - }] - proc usage {args} { - #lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received - lassign [dict values [punk::args::parse $args withid ::punk::args::usage]] leaders opts values received - set id [dict get $values id] - set real_id [real_id $id] - if {$real_id eq ""} { - error "punk::args::usage - no such id: $id" - } - #-scheme punk_info ?? - arg_error "" [punk::args::get_spec $real_id] {*}$opts -aserror 0 - } - - lappend PUNKARGS [list { - @id -id ::punk::args::get_by_id - @cmd -name punk::args::get_by_id - @values -min 1 - id - arglist -type list -help\ - "list containing arguments to be parsed as per the - argument specification identified by the supplied id." - }] - - - #deprecate? - proc get_by_id {id arglist} { - set definitionlist [punk::args::raw_def $id] - if {[llength $definitionlist] == 0} { - error "punk::args::get_by_id - no such id: $id" - } - #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] - tailcall ::punk::args::get_dict $definitionlist $arglist - } - - #consider - - #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) - #parse ?-flag val?... -- $arglist withid $id - #parse ?-flag val?... -- $arglist withdef $def ?$def?... - - #an experiment.. ideally we'd like arglist at the end? - #parse_withid ?-flag val?.. $id $arglist - #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? - #no possible equivalent for parse_withdef ??? - - lappend PUNKARGS [list { - @id -id ::punk::args::parse - @cmd -name punk::args::parse -help\ - "parse and validate command arguments based on a definition. - - In the 'withid' form the definition is a pre-existing record that has been - created with ::punk::args::define, or indirectly by adding a definition to - the PUNKARGS variable in a namespace which is then registered in - punk::args::register::NAMESPACES, or by a previous call to punk::parse - using 'withdef' and a definition block containing an @id -id directive. - - In the 'withdef' form - the definition is created on the first call and - cached thereafter, if the id didn't already exist. - - form1: parse $arglist ?-flag val?... withid $id - form2: parse $arglist ?-flag val?... withdef $def ?$def? - see punk::args::define - - Returns a dict of information regarding the parsed arguments - example of basic usage for single option only: - punk::args::define { - @id -id ::myns::myfunc - @cmd -name myns::myfunc - @leaders -min 0 -max 0 - @opts - -configfile -type existingfile - #type none makes it a solo flag - -verbose -type none - @values -min 0 -max 0 - } - proc myfunc {args} { - set argd [punk::args::parse $args withid ::myns::myfunc] - lassign [dict values $argd] leaders opts values received solos - if {[dict exists $received] -configfile} { - puts \"have option for existing file [dict get $opts -configfile]\" - } - } - The leaders, opts, values keys in the parse result dict are proper dicts. - The received key is dict-like but can have repeated keys for arguments than can - accept multiples. The value for each received element is the ordinal position. - The solos key refers to a list of solo flags received (those specified with - -type none). This is generally only useful to assist in passing arguments on - to another procedure which also requires solos, because the opts dict contains - solo flags with a 1 value or a list of 1's if it was a solo with -multiple true - specified. - " - @form -form {withid withdef} - @leaders -min 1 -max 1 - arglist -type list -optional 0 -help\ - "Arguments to parse - supplied as a single list" - - @opts - -form -type list -default * -help\ - "Restrict parsing to the set of forms listed. - Forms are the orthogonal sets of arguments a - command can take - usually described in 'synopsis' - entries." - #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance - #todo - configurable per interp/namespace - -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} - - @values -min 2 - - @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" - @values -max 2 - withid -type literal -help\ - "The literal value 'withid'" - id -type string -help\ - "id of punk::args definition for a command" - - - @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" - withdef -type literal -help\ - "The literal value 'withdef'" - - #todo - make -dynamic obsolete - use @dynamic directive instead - def -type string -multiple 1 -optional 0 -help\ - "Each remaining argument is a block of text - defining argument definitions. - As a special case, -dynamic may be - specified as the 1st 2 arguments. These are - treated as an indicator to punk::args about - how to process the definition." - - }] - proc parse {args} { - #puts "punk::args::parse --> '$args'" - set tailtype "" ;#withid|withdef - if {[llength $args] < 3} { - #error "punk::args::parse - invalid call. < 3 args" - punk::args::parse $args withid ::punk::args::parse - } - set opts_and_vals $args - set parseargs [lpop opts_and_vals 0] - - set opts [list] - set values [list] - for {set i 0} {$i < [llength $opts_and_vals]} {incr i} { - if {[string match -* [lindex $opts_and_vals $i]]} { - if {[catch { - lappend opts [lpop opts_and_vals 0] [lpop opts_and_vals 0] - }]} { - #unhappy path - not enough options - #review - which form of punk::args::parse? - punk::args::parse $args withid ::punk::args::parse - } - incr i -1 - #lappend opts $a [lindex $opts_and_vals $i] - } else { - break - } - } - #set values [lrange $opts_and_vals $i end] - set values $opts_and_vals - #puts "---values: $values" - set tailtype [lindex $values 0] - set tailargs [lrange $values 1 end] - - - #set split [lsearch -exact $tailargs withid] - #if {$split < 0} { - # set split [lsearch -exact $tailargs withdef] - # if {$split < 0} { - # #punk::args::usage arg_error? - # #error "punk::args::parse - invalid call. keyword withid|withdef required" - # punk::args::parse $args withid ::punk::args::parse - # } else { - # set tailtype withdef - #} - #} else { - # set tailtype withid - #} - #set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. - - - #if {[llength $opts] % 2} { - #error "punk::args::parse Even number of -flag val pairs required after arglist" - #} - - #Default the -errorstyle to enhanced - # (slowest on unhappy path - but probably clearest for playing with new APIs interactively) - # - application devs should distribute a config file with an errorstyle override if desired. - # - devs who prefer a different default for interactive use should create a config for it. (todo) - set defaultopts [dict create\ - -form {*}\ - -errorstyle enhanced\ - ] - - #todo - load override_errorstyle from configuration - #dict set defaultopts -errorstyle $ - #puts "def: $defaultopts opts: $opts" - set opts [dict merge $defaultopts $opts] - dict for {k v} $opts { - switch -- $k { - -form - -errorstyle { - } - default { - #punk::args::usage $args withid ::punk::args::parse ?? - #error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" - punk::args::parse $args withid ::punk::args::parse - } - } - } - switch -- $tailtype { - withid { - if {[llength $tailargs] != 1} { - #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - punk::args::parse $args withid ::punk::args::parse - } - set id [lindex $tailargs 0] - #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" - #puts stdout "punk::args::parse '$parseargs' withid $id, options: $opts" - set deflist [raw_def $id] - if {[llength $deflist] == 0} { - error "punk::args::parse - no such id: $id" - } - } - withdef { - set deflist $tailargs - if {[llength $deflist] < 1} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" - #puts stdout "punk::args::parse '$parseargs' with [llength $deflist] definition blocks, options: $opts" - } - default { - error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" - } - } - try { - #puts stdout "parse --> get_dict $parseargs -form [dict get $opts -form]" - set result [punk::args::get_dict $deflist $parseargs -form [dict get $opts -form]] - } trap {PUNKARGS VALIDATION} {msg erroropts} { - set opt_errorstyle [dict get $opts -errorstyle] - - #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - - - set ecode [dict get $erroropts -errorcode] - #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... - set msg [string map [list %caller% [Get_caller]] $msg] - switch -- $opt_errorstyle { - minimal { - return -options [list -code error -errorcode $ecode] $msg - } - basic { - #No table layout - unix manpage style - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg -form [dict get $opts -form]] - } - return -options [list -code error -errorcode $ecode] $msg - } - standard { - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] - } - return -options [list -code error -errorcode $ecode] $msg - } - enhanced { - set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below) - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - set ecode_summary [lrange $ecode 0 2] - if {$badarg ne ""} { - lappend ecode_summary -badarg $badarg - } - catch {package require punk::lib} - if {[package provide punk::lib] ne ""} { - append msg \n [punk::lib::showdict -roottype list $estack */*] - } - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] - append msg \n "::errorCode summary: $ecode_summary" - return -options [list -code error -errorcode $ecode] $msg - } else { - #why? todo? - append msg \n "(enhanced error information unavailable)" - append msg \n "::errorCode summary: $ecode_summary" - return -options [list -code error -errorcode $ecode] $msg - } - } - debug { - puts stderr "errorstyle debug not implemented" - return -options [list -code error -errorcode $ecode] $msg - } - default { - puts stderr "errorstyle $opt_errorstyle not recognised: expected one of minimal basic standard enhanced debug" - return -options [list -code error -errorcode $ecode] $msg - } - } - } trap {PUNKARGS} {msg erropts} { - append msg \n "Unexpected PUNKARGS error" - return -options [list -code error -errorcode $ecode] $msg - } trap {} {msg erroropts} { - #review - #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. - #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. - throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] - } - return $result - } - proc parseXXX {args} { - #no solo flags allowed for parse function itself. (ok for arglist being parsed) - set opts [dict create] ;#repeated flags will override earlier. That's ok here. - set arglist {} - set got_arglist 0 - set tailtype "" ;#withid|withdef - set id "" - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {[string match -* $a]} { - dict set opts $a [lindex $args $i+1] - incr i - } else { - set arglist $a - set got_arglist 1 - set tailtype [lindex $args $i+1] - if {$tailtype eq "withid"} { - if {[llength $args] != $i+3} { - error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - } - set id [lindex $args $i+2] - break - } elseif {$tailtype eq "withdef"} { - if {[llength $args] < $i+3} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - set deflist [lrange $args $i+2 end] - break - } else { - error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" - } - } - } - if {!$got_arglist} { - error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." - } - #assert tailtype eq withid|withdef - if {$tailtype eq "withid"} { - #assert $id was provided - return "parse [llength $arglist] args withid $id, options:$opts" - } else { - #assert llength deflist >=1 - return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" - } - #TODO - } - - - #return number of values we can assign to cater for variable length clauses such as {"elseif" expr "?then?" body} - #review - efficiency? each time we call this - we are looking ahead at the same info - proc _get_dict_can_assign_value {idx values nameidx names namesreceived formdict} { - set ARG_INFO [dict get $formdict ARG_INFO] - set all_remaining [lrange $values $idx end] - set thisname [lindex $names $nameidx] - set thistype [dict get $ARG_INFO $thisname -type] - set tailnames [lrange $names $nameidx+1 end] - - #todo - work backwards with any (optional or not) literals at tail that match our values - and remove from assignability. - set ridx 0 - foreach clausename [lreverse $tailnames] { - #puts "=============== clausename:$clausename all_remaining: $all_remaining" - set typelist [dict get $ARG_INFO $clausename -type] - if {[lsearch $typelist literal*] == -1} { - break - } - set max_clause_length [llength $typelist] - if {$max_clause_length == 1} { - #basic case - set alloc_ok 0 - #set v [lindex $values end-$ridx] - set v [lindex $all_remaining end] - set tp [lindex $typelist 0] - #review - ignore ?literal? and ?literal(xxx)? when clause-length == 1? (should raise error during definition instead? - #we shouldn't have an optional clause member if there is only one member - the whole name should be marked -optional true instead. - set tp [string trim $tp ?] - foreach tp_member [split $tp |] { - if {[string match literal* $tp]} { - set litinfo [string range $tp 7 end] ;#get bracketed part if of form literal(xxx) - if {[string match (*) $litinfo]} { - set match [string range $litinfo 1 end-1] - } else { - #plain "literal" without bracketed specifier - match to argument name - set match $clausename - } - if {$v eq $match} { - set alloc_ok 1 - lpop all_remaining - if {![dict get $ARG_INFO $clausename -multiple]} { - lpop tailnames - } - #type (or one of the possible type alternates) matched a literal - break - } - } - } - if {!$alloc_ok} { - if {![dict get $ARG_INFO $clausename -optional]} { - break - } - } - - } else { - #review - we assume here that we don't have a set of clause-members where all are marked optional (?membertype?) - #This is better caught during definition. - #e.g rn = {elseif expr (?then?) body} typelist = {literal expr ?literal? script} - #set cvals [lrange $values end-$ridx end-[expr {$ridx + $max_clause_length-1}]] - set cvals [lrange $values end-[expr {$ridx + $max_clause_length-1}] end-$ridx] - set rcvals [lreverse $cvals] - set alloc_count 0 - #clause name may have more entries than types - extras at beginning are ignored - set rtypelist [lreverse $typelist] - set rclausename [lrange [lreverse $clausename] 0 [llength $typelist]-1] - #assert length of rtypelist >= $rclausename - set alloc_ok 0 - set reverse_type_index 0 - #todo handle type-alternates - # for example: -type {string literal(x)|literal(y)} - foreach tp $rtypelist membername $rclausename { - #(membername may be empty if not enough elements) - #set rv [lindex $rcvals end-$alloc_count] - set rv [lindex $all_remaining end-$alloc_count] - if {[string match {\?*\?} $tp]} { - set clause_member_optional 1 - } else { - set clause_member_optional 0 - } - set tp [string trim $tp ?] - if {[string match literal* $tp]} { - set litinfo [string range $tp 7 end] - if {[string match (*) $litinfo]} { - set match [string range $litinfo 1 end-1] - } else { - #if membername empty - equivalent to "literal()" - matches empty string literal - #edgecase - possibly? no need for empty-string literals - but allow it without error. - set match $membername - } - #todo -literalprefix - if {$rv eq $match} { - set alloc_ok 1 ;#we need at least one literal-match to set alloc_ok - incr alloc_count - } else { - if {$clause_member_optional} { - # - } else { - set alloc_ok 0 - break - } - } - } else { - if {$clause_member_optional} { - #review - optional non-literal makes things harder.. - #we don't want to do full type checking here - but we now risk allocating an item that should actually - #be allocated to the previous value - set prev_type [lindex $rtypelist $reverse_type_index+1] - if {[string match literal* $prev_type]} { - set litinfo [string range $prev_type 7 end] - #todo -literalprefix - if {[string match (*) $litinfo]} { - set match [string range $litinfo 1 end-1] - } else { - #prev membername - set match [lindex $rclausename $reverse_type_index+1] - } - if {$rv ne $match} { - #current val doesn't match previous type - allocate here - incr alloc_count - } - } else { - #no literal to anchor against.. - incr alloc_count - } - } else { - #allocate regardless of type - we're only matching on arity and literal positioning here. - #leave final type-checking for later. - incr alloc_count - } - } - incr reverse_type_index - } - if {$alloc_ok && $alloc_count > 0} { - #set n [expr {$alloc_count -1}] - #set all_remaining [lrange $all_remaining end-$n end] - set all_remaining [lrange $all_remaining 0 end-$alloc_count] - #don't lpop if -multiple true - if {![dict get $ARG_INFO $clausename -multiple]} { - lpop tailnames - } - } else { - break - } - } - incr ridx - } - set num_remaining [llength $all_remaining] - - if {[dict get $ARG_INFO $thisname -optional] || ([dict get $ARG_INFO $thisname -multiple] && $thisname in $namesreceived)} { - #todo - check -multiple for required min/max (not implemented: make -multiple accept ?) - #thisname already satisfied, or not required - set tail_needs 0 - foreach t $tailnames { - if {![dict get $ARG_INFO $t -optional]} { - set min_clause_length [llength [lsearch -all -not [dict get $ARG_INFO $t -type] {\?*\?}]] - incr tail_needs $min_clause_length - } - } - set all_remaining [lrange $all_remaining 0 end-$tail_needs] - } - - #thistype - set alloc_ok 1 ;#default assumption only - set alloc_count 0 - set resultlist [list] - set n [expr {[llength $thistype]-1}] - #name can have more or less items than typelist - set thisnametail [lrange $thisname end-$n end] - set tpidx 0 - set newtypelist $thistype - foreach tp $thistype membername $thisnametail { - set v [lindex $all_remaining $alloc_count] - if {[string match {\?*\?} $tp]} { - set clause_member_optional 1 - } else { - set clause_member_optional 0 - } - set tp [string trim $tp ?] - - set member_satisfied 0 - - #----------------------------------------------------------------------------------- - #first build list of any literals - and whether any are literalprefix - set literals [list] - set literalprefixes [list] - set nonliterals [list] - set dict_member_match [dict create] - foreach tp_member [split $tp |] { - #JJJJ - if {[string match literal* $tp_member]} { - if {[string match literalprefix* $tp_member]} { - set litinfo [string range $tp_member 13 end] - if {[string match (*) $litinfo]} { - lappend literalprefixes [string range $litinfo 1 end-1] - } else { - lappend literalprefixes $membername - } - dict set dict_member_match $tp_member [lindex $literalprefixes end] - } else { - set litinfo [string range $tp_member 7 end] - if {[string match (*) $litinfo]} { - lappend literals [string range $litinfo 1 end-1] - } else { - lappend literals $membername - } - dict set dict_member_match $tp_member [lindex $literals end] - } - } else { - lappend nonliterals $tp_member - } - } - #----------------------------------------------------------------------------------- - #asert - each tp_member is a key in dict_member_match - if {[llength $nonliterals] > 0} { - #presence of any ordinary type as one of the alternates - means we consider it a match - #we don't validate here -leave validation for later (review) - set member_satisfied 1 - } else { - if {$v in $literals} { - set member_satisfied 1 - } else { - #literals is included in the prefix-calc - but a shortened version of an entry in literals is not allowed - #(exact match would have been caught in other branch of this if) - set full_v [tcl::prefix::match -error "" [list {*}$literals {*}$literalprefixes] $v] - if {$full_v ne "" && $full_v ni $literals} { - #matched prefix must be for one of the entries in literalprefixes - valid - set member_satisfied 1 - } - } - } - - #foreach tp_member [split $tp |] { - # if {[string match literal* $tp_member]} { - # #todo - support literal prefix-matching - # #e.g see ::readFile filename ?text|binary? - must accept something like readfile xxx.txt b - # set litinfo [string range $tp_member 7 end] - # if {[string match (*) $litinfo]} { - # set match [string range $litinfo 1 end-1] - # } else { - # set match $membername - # } - # set match [dict get $dict_member_match $tp_member] - # if {$v eq $match} { - # set member_satisfied 1 - # break - # } - # } else { - # #we don't validate here -leave validation for later (review) - # set member_satisfied 1 - # break - # } - #} - - if {$member_satisfied} { - if {$clause_member_optional && $alloc_count >= [llength $all_remaining]} { - if {[dict exists $ARG_INFO $thisname -typedefaults]} { - set d [lindex [dict get $ARG_INFO $thisname -typedefaults] $tpidx] - lappend resultlist $d - lset newtypelist $tpidx ?defaulted-$tp? - } else { - lset newtypelist $tpidx ?omitted-$tp? - lappend resultlist "" - } - } else { - lappend resultlist $v - incr alloc_count - } - } else { - if {$clause_member_optional} { - if {[dict exists $ARG_INFO $thisname -typedefaults]} { - set d [lindex [dict get $ARG_INFO $thisname -typedefaults] $tpidx] - lappend resultlist $d - lset newtypelist $tpidx ?defaulted-$tp? - } else { - lappend resultlist "" - lset newtypelist $tpidx ?omitted-$tp? - } - } else { - set alloc_ok 0 - } - } - - if {$alloc_count > [llength $all_remaining]} { - set alloc_ok 0 - break - } - incr tpidx - } - - #?omitted-*? and ?defaulted-*? in typelist are a way to know which elements in the clause were missing/defaulted - #so that they are not subject to type validation - #such elements shouldn't be subject to validation - if {$alloc_ok} { - set d [dict create consumed $alloc_count resultlist $resultlist typelist $newtypelist] - } else { - set d [dict create consumed 0 resultlist {} typelist $thistype] - } - #puts ">>>> _get_dict_can_assign_value $d" - return $d - } - - #todo? - a version of get_dict that directly supports punk::lib::tstr templating - #rename get_dict - # - - #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 get_dict {deflist rawargs args} { - #see arg_error regarding considerations around unhappy-path performance - - if {[llength $args] % 2 != 0} { - error "punk::args::get_dict args must be a dict of option value pairs" - } - set defaults [dict create\ - -form *\ - ] - set opts [dict merge $defaults $args] - dict for {k v} $opts { - switch -- $k { - -form {} - default { - error "punk::args::get_dict Unexpected option '$k' Known options -form" - } - } - } - - - #*** !doctools - #[call [fun get_dict] [arg deflist] [arg rawargs] [arg args]] - #[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 values - #[para]ARGUMENTS: - #[list_begin arguments] - #[arg_def list-of-multiline-string deflist] - #[para] These are blocks 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 defining a flag 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 etc - #[para]Each optionspec line defining a positional argument is of the form: - #[para]argumentname -key val -ky2 val2... - #[para]where the valid keys for each option specification are: -default -type -range -choices - #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value - #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. - #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. - #[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, - #but it could be a manually constructed list of values made for example from positional args defined in the proc. - #[list_end] - #[para] - - #consider line-processing example below for which we need info complete to determine record boundaries - #punk::args::get_dict [list { - # @opts - # -opt1 -default {} - # -opt2 -default { - # etc - # } - # @values -multiple 1 - #}] $args - - - - - #rawargs: args values to be parsed - #we take a definition list rather than resolved argspecs - because the definition could be dynamic - - #if definition has been seen before, - #define will either return a permanently cached argspecs (-dynamic 0) - or - # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. - set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]] - - # ----------------------------------------------- - # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) - tcl::dict::with argspecs {} ;#turn keys into vars - #e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info,id_info,form_names - # ----------------------------------------------- - set opt_form [dict get $opts -form] - if {$opt_form eq "*"} { - set selected_forms $form_names - } elseif {[string is integer -strict $opt_form]} { - if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { - error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set selected_forms [list [lindex $form_names $opt_form]] - } else { - if {$opt_form ni $form_names} { - error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set selected_forms [list $opt_form] - } - - - #puts "-arg_info->$arg_info" - set flagsreceived [list] ;#for checking if required flags satisfied - set solosreceived [list] - set multisreceived [list] - #secondary purpose: - #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 ? - - # -- --- --- --- - # Handle leading positionals - # todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ? - - #todo - handle multiple fids? - set fid [lindex $selected_forms 0] - set formdict [dict get $FORMS $fid] - tcl::dict::with formdict {} - #populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc - if {$VAL_MIN eq ""} { - set valmin 0 - #set VAL_MIN 0 - foreach v $VAL_NAMES { - if {![dict get $ARG_INFO $v -optional]} { - # todo variable clause lengths (items marked optional in types using leading&trailing questionmarks) - # e.g -types {a ?xxx?} - #this has one required and one optional - set typelist [dict get $ARG_INFO $v -type] - set clause_length 0 - foreach t $typelist { - if {![string match {\?*\?} $t]} { - incr clause_length - } - } - incr valmin $clause_length - } - } - } else { - set valmin $VAL_MIN - } - - set pre_values {} - - set argnames [tcl::dict::keys $ARG_INFO] - #set optnames [lsearch -all -inline $argnames -*] - #JJJ - set all_opts [list] - set lookup_optset [dict create] - foreach optset $OPT_NAMES { - #optset e.g {-x|--longopt|--longopt=|--otherlongopt} - set optmembers [split $optset |] - foreach optdef $optmembers { - set opt [string trimright $optdef =] - if {$opt ni $all_opts} { - dict set lookup_optset $opt $optset - lappend all_opts $opt - } - } - } - set ridx 0 - set rawargs_copy $rawargs - set remaining_rawargs $rawargs - set leader_posn_name "" - set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) - set is_multiple 0 ;#last leader may be multi - - - #consider for example: LEADER_NAMES {"k v" leader2 leader3} with -type {int number} & -type {int int int} & -type string - #(i.e clause-length of 2 3 and 1) - #This will take 6 raw leaders to fill in the basic case that all are -optional 0 and -multiple 0 - #REVIEW - what about optional members in leaders e.g -type {int ?double?} - set named_leader_args_max 0 - foreach ln $LEADER_NAMES { - set typelist [dict get $ARG_INFO $ln -type] - incr named_leader_args_max [llength $typelist] - } - - #set id [dict get $argspecs id] - #if {$id eq "::if"} { - #puts stderr "::if" - #puts stderr "get_dict--> remaining_rawargs: $remaining_rawargs" - #} - - - #REVIEW - this attempt to classify leaders vs opts vs values doesn't account for leaders with clauses containing optional elements - #e.g @leadrs {x -type {int ?int?}} - set nameidx 0 - if {$LEADER_MAX != 0} { - for {set ridx 0} {$ridx < [llength $rawargs]} {incr ridx} { - set raw [lindex $rawargs $ridx] ;#received raw arg - if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { - break - } - if {[llength $LEADER_NAMES] && $nameidx == [llength $LEADER_NAMES]-1} { - #at last named leader - set leader_posn_name [lindex $LEADER_NAMES $nameidx] - if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { - set is_multiple 1 - } - } elseif {$ridx > $named_leader_args_max-1} { - #beyond names - retain name if -multiple was true - if {!$is_multiple} { - set leader_posn_name "" - } - } else { - set leader_posn_name [lindex $LEADER_NAMES $nameidx] ;#may return empty string - } - if {$OPT_MAX ne "0"} { - #all_opts includes end_of_opts marker -- if configured - no need to explicitly check for it separately - set flagname $raw - if {[string match --* $raw]} { - set eposn [string first = $raw] - # --flag=xxx - if {$eposn >=3} { - set flagname [string range $raw 0 $eposn-1] - } - } - set matchopt [::tcl::prefix::match -error {} $all_opts $flagname] - if {$matchopt ne ""} { - #flaglike matches a known flag - don't treat as leader - break - } - } - - #for each branch - break or lappend - if {$leader_posn_name ne ""} { - set leader_type [dict get $ARG_INFO $leader_posn_name -type] - #todo - variable clauselengths e.g 'if' command which has optional 'then' and 'else' "noise words" - set clauselength [llength $leader_type] - set min_clauselength 0 - foreach t $leader_type { - if {![string match {\?*\?} $t]} { - incr min_clauselength - } - } - if {$leader_posn_name ni $LEADER_REQUIRED} { - #optional leader - - #most adhoc arg processing will allocate based on number of args rather than matching choice values first - #(because a choice value could be a legitimate data value) - - #review - option to process in this manner? - #first check if the optional leader value is a match for a choice ? - #if {[dict exists $arg_info $leader_posn_name -choices]} { - # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] $raw] - # if {$vmatch ne ""} { - # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values - # lappend pre_values [lpop remaining_rawargs 0] - # incr ridx - # continue - # } - #} - if {[llength $remaining_rawargs] < $min_clauselength} { - #not enough remaining args to fill even this optional leader - #rather than raise error here - perform our break (for end of leaders) and let the code below handle it - break - } - - #check if enough remaining_rawargs to fill any required values - if {$valmin > 0 && [llength $remaining_rawargs] - $min_clauselength < $valmin} { - break - } - - #leadername may be a 'clause' of arbitrary length (e.g -type {int double} or {int string number}) - set end_leaders 0 - foreach t $leader_type { - set raw [lindex $rawargs $ridx] - if {[string match {\?*\?} $t] && [string match -* $raw]} { - #review - limitation of optional leaders is they can't be same value as any defined flags/opts - set flagname $raw - if {[string match --* $raw]} { - set eposn [string first = $raw] - # --flag=xxx - if {$eposn >=3} { - set flagname [string range $raw 0 $eposn-1] - } - } - set matchopt [::tcl::prefix::match -error {} $all_opts $flagname] - if {$matchopt ne ""} { - #don't consume if flaglike (and actually matches an opt) - set end_leaders 1 - break ;#break out of looking at -type members in the clause - } else { - #unrecognised flag - treat as value for optional member of the clause - lappend pre_values [lpop remaining_rawargs 0] - incr ridx - } - } else { - lappend pre_values [lpop remaining_rawargs 0] - incr ridx - } - } - incr ridx -1 ;#leave ridx at index of last r that we set - if {$end_leaders} { - break - } - if {!$is_multiple} { - incr nameidx - } - dict incr leader_posn_names_assigned $leader_posn_name - } else { - #clause is required - if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { - #already accepted at least one complete clause for this name - requirement satisfied - now equivalent to optional - if {[llength $remaining_rawargs] < $min_clauselength} { - #not enough remaining args to fill even this optional leader - #rather than raise error here - perform our break (for end of leaders) and let the code below handle it - break - } - - if {$valmin > 0 && [llength $remaining_rawargs] - $min_clauselength < $valmin} { - break - } - } - #if we didn't break - requirement is not yet satisfied, or is satisfied but still enough remaining_rawargs for required values - #we still need to check if enough values for the leader itself - if {[llength $remaining_rawargs] < $min_clauselength} { - #not enough remaining args to fill *required* leader - break - } - - set end_leaders 0 - foreach t $leader_type { - set raw [lindex $rawargs $ridx] - if {[string match {\?*\?} $t] && [string match -* $raw]} { - #review - limitation of optional leaders is they can't be same value as any defined flags/opts - - set matchopt [::tcl::prefix::match -error {} $all_opts $raw] - if {$matchopt ne ""} { - #don't consume if flaglike (and actually matches an opt) - set end_leaders 1 - break ;#break out of looking at -type members in the clause - } else { - #unrecognised flag - treat as value for optional member of the clause - lappend pre_values [lpop remaining_rawargs 0] - incr ridx - } - } else { - lappend pre_values [lpop remaining_rawargs 0] - incr ridx - } - } - incr ridx -1 - if {$end_leaders} { - break - } - if {!$is_multiple} { - incr nameidx - } - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #unnamed leader - if {$LEADER_MIN ne "" } { - if {$ridx > $LEADER_MIN-1} { - if {$LEADER_MAX ne "" && $ridx == $LEADER_MAX} { - break - } else { - if {$valmin > 0} { - if {[llength $remaining_rawargs] > $valmin} { - lappend pre_values [lpop remaining_rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } else { - break - } - } else { - lappend pre_values [lpop remaining_rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } - } else { - #haven't reached LEADER_MIN - lappend pre_values [lpop remaining_rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #review - if is_multiple, keep going if enough remaining_rawargs for values? - break - } - } - - #incr ridx - } ;# end foreach r $rawargs_copy - } - #puts "get_dict ================> pre: $pre_values" - - set argstate $ARG_INFO ;#argstate may have entries added - set arg_checks $ARG_CHECKS - - if {$LEADER_MIN eq ""} { - set leadermin 0 - } else { - set leadermin $LEADER_MIN - } - if {$LEADER_MAX eq ""} { - set leadermax -1 - } else { - set leadermax $LEADER_MAX - } - - if {$VAL_MAX eq ""} { - set valmax -1 - } else { - set valmax $VAL_MAX - } - - #assert leadermax leadermin are numeric - #assert - remaining_rawargs has been reduced by leading positionals - - set opts [dict create] ;#don't set to OPT_DEFAULTS here - #set id [dict get $argspecs id] - #if {$id eq "::if"} { - #puts stderr "::if" - #puts stderr "get_dict--> pre_values: $pre_values" - #puts stderr "get_dict--> remaining_rawargs: $remaining_rawargs" - #} - - set leaders [list] - set arglist {} - set post_values {} - #valmin, valmax - #puts stderr "remaining_rawargs: $remaining_rawargs" - #puts stderr "argstate: $argstate" - if {$OPT_MAX ne "0" && [lsearch $remaining_rawargs -*] >= 0} { - #contains at least one possible flag - set maxidx [expr {[llength $remaining_rawargs] -1}] - if {$valmax == -1} { - set vals_total_possible [llength $remaining_rawargs] - set vals_remaining_possible $vals_total_possible - } else { - set vals_total_possible $valmax - set vals_remaining_possible $vals_total_possible - } - for {set i 0} {$i <= $maxidx} {incr i} { - set remaining_args_including_this [expr {[llength $remaining_rawargs] - $i}] - #lowest valmin is 0 - if {$remaining_args_including_this <= $valmin} { - # if current arg is -- it will pass through as a value here - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - break - } - set a [lindex $remaining_rawargs $i] - #if {$a eq "--"} { - # #REVIEW - # #remaining num args <= valmin already covered above - # if {$valmax != -1} { - # #finite max number of vals - # if {$remaining_args_including_this == $valmax} { - # #assume it's a value. - # set arglist [lrange $remaining_rawargs 0 $i-1] - # set post_values [lrange $remaining_rawargs $i end] - # } else { - # #assume it's an end-of-options marker - # lappend flagsreceived -- - # set arglist [lrange $remaining_rawargs 0 $i] - # set post_values [lrange $remaining_rawargs $i+1 end] - # } - # } else { - # #unlimited number of post_values accepted - # #treat this as eopts - we don't care if remainder look like options or not - # lappend flagsreceived -- - # set arglist [lrange $remaining_rawargs 0 $i] - # set post_values [lrange $remaining_rawargs $i+1 end] - # } - # break - #} - if {[string match --* $a]} { - if {$a eq "--"} { - if {$a in $OPT_NAMES} { - #treat this as eopts - we don't care if remainder look like options or not - lappend flagsreceived -- - set arglist [lrange $remaining_rawargs 0 $i] - set post_values [lrange $remaining_rawargs $i+1 end] - } else { - #assume it's a value. - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - } - break - } else { - set eposn [string first = $a] - if {$eposn > 2} { - #only allow longopt-style = for double leading dash longopts - #--*= usage - if {$flagname ni $raw_optionset_members} { - # - set msg "Bad options for %caller%. Option $optionset at index [expr {$i-1}] requires a value, but '$flagname' not specified in definition to allow space-separated value." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list badoptionformat $optionset index [expr {$i-1}]] -badarg $optionset -argspecs $argspecs]] $msg - } - } - if {$solo_only} { - #same logic as 'solo' branch below for -type none - if {[tcl::dict::get $argstate $optionset -multiple]} { - if {$api_opt ni $flagsreceived} { - #override any default - don't lappend to it - tcl::dict::set opts $api_opt 1 - } else { - tcl::dict::lappend opts $api_opt 1 - } - if {$api_opt ni $multisreceived} { - lappend multisreceived $api_opt - } - } else { - tcl::dict::set opts $api_opt 1 - } - incr vals_remaining_possible -1 - lappend solosreceived $api_opt ;#dups ok - } else { - #check if it was actually a value that looked like a flag - if {$i == $maxidx} { - #if no optvalue following - assume it's a value - #(caller should probably have used -- before it) - #review - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - break - } - #flagval comes from next remaining rawarg - set flagval [lindex $remaining_rawargs $i+1] - if {[tcl::dict::get $argstate $optionset -multiple]} { - #don't lappend to default - we need to replace if there is a default - if {$api_opt ni $flagsreceived} { - tcl::dict::set opts $api_opt [list $flagval] - } else { - tcl::dict::lappend opts $api_opt $flagval - } - if {$api_opt ni $multisreceived} { - lappend multisreceived $api_opt - } - } else { - tcl::dict::set opts $api_opt $flagval - } - #incr i to skip flagval - incr vals_remaining_possible -2 - if {[incr i] > $maxidx} { - set msg "Bad options for %caller%. No value supplied for last option $optionset at index [expr {$i-1}] which is not marked with -type none" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $optionset index [expr {$i-1}]] -badarg $optionset -argspecs $argspecs]] $msg - } - } - } - } else { - #solo - if {[tcl::dict::get $argstate $optionset -multiple]} { - if {$api_opt ni $flagsreceived} { - #override any default - don't lappend to it - tcl::dict::set opts $api_opt 1 - } else { - tcl::dict::lappend opts $api_opt 1 - } - if {$api_opt ni $multisreceived} { - lappend multisreceived $api_opt - } - } else { - tcl::dict::set opts $api_opt 1 - } - incr vals_remaining_possible -1 - lappend solosreceived $api_opt ;#dups ok - } - lappend flagsreceived $api_opt ;#dups ok - } else { - #starts with - but unmatched option flag - #comparison to valmin already done above - if {$valmax ne -1 && $remaining_args_including_this <= $valmax} { - #todo - look at optspec_default and see if solo/vs opt-val pair - #we may need to lookahead by 2 regarding valmax valmin - - #even if optany - assume an unknown within the space of possible values is a value - #unmatched option in right position to be considered a value - treat like eopts - #review - document that an unspecified arg within range of possible values will act like eopts -- - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - break - } - if {!([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { - if {$OPT_ANY} { - #exlude argument with whitespace from being a possible option e.g dict - #todo - passthrough of unrecognised --longopt=xxx without looking for following flag-value - set eposn [string first = $a] - if {[string match --* $a] && $eposn > 2} { - #only allow longopt-style = for double leading dash longopts - #--*= $maxidx} { - set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg - #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a - } - incr vals_remaining_possible -2 - } else { - #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none - if {[tcl::dict::get $argstate $a -multiple]} { - if {![tcl::dict::exists $opts $a]} { - tcl::dict::set opts $a 1 - } else { - tcl::dict::lappend opts $a 1 - } - if {$a ni $multisreceived} { - lappend multisreceived $a - } - } else { - tcl::dict::set opts $a 1 - } - incr vals_remaining_possible -1 - lappend solosreceived $a - } - } - - lappend flagsreceived $flagreceived ;#adhoc flag name (if --x=1 -> --x) - } else { - if {[llength $OPT_NAMES]} { - set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES (3)" - } else { - set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any|-arbitrary false" - } - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg - #arg_error $errmsg $argspecs -badarg $optionset - } - } else { - #not a flag/option - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - break - } - } - - } - #set values [list {*}$pre_values {*}$post_values] - set leaders $pre_values - set values $post_values - } else { - set leaders $pre_values - set values $remaining_rawargs - #set values [list {*}$pre_values {*}$remaining_rawargs] ;#no -flags detected - set arglist [list] - } - #set id [dict get $argspecs id] - #if {$id eq "::if"} { - #puts stderr "::if" - #puts stderr "get_dict--> arglist: $arglist" - #puts stderr "get_dict--> leaders: $leaders" - #puts stderr "get_dict--> values: $values" - #} - - #--------------------------------------- - set ordered_opts [dict create] - set unaliased_opts [lmap v $OPT_NAMES {string trimright [lindex [split $v |] end] =}] - #unaliased_opts is list of 'api_opt' (to handle flag aliases of form -a1|-a2|-api_opt) - # e.g -fg|-foreground - # e.g -x|--fullname= - #Resulting unaliased_opts from list {-fg|-foreground -x|--fullname=} should be {-foreground --fullname} - foreach o $unaliased_opts optset $OPT_NAMES { - if {[dict exists $opts $o]} { - dict set ordered_opts $o [dict get $opts $o] - } elseif {[dict exists $OPT_DEFAULTS $optset]} { - dict set ordered_opts $o [dict get $OPT_DEFAULTS $optset] - } - } - #add in possible arbitrary opts after the defined opts, due to @opts directive flag '-any|-arbitrary true' - dict for {o oval} $opts { - if {![dict exists $ordered_opts $o]} { - dict set ordered_opts $o $oval - } - } - set opts $ordered_opts - #--------------------------------------- - - - set positionalidx 0 ;#index for unnamed positionals (both leaders and values) - set leadername_multiple "" - set leadernames_received [list] - - set num_leaders [llength $leaders] - - #---------------------------------------- - #Establish firm leaders ordering - set leaders_dict [dict create] - foreach lname [lrange $LEADER_NAMES 0 $num_leaders-1] { - dict set leaders_dict $lname {} - } - set leaders_dict [dict merge $leaders_dict $LEADER_DEFAULTS] - #---------------------------------------- - - set start_position $positionalidx - set nameidx 0 - #MAINTENANCE - (*nearly*?) same loop logic as for value - for {set ldridx 0} {$ldridx < [llength $leaders]} {incr ldridx} { - set leadername [lindex $LEADER_NAMES $nameidx] - set ldr [lindex $leaders $ldridx] - if {$leadername ne ""} { - set leadertypelist [tcl::dict::get $argstate $leadername -type] - - set assign_d [_get_dict_can_assign_value $ldridx $leaders $nameidx $LEADER_NAMES $leadernames_received $formdict] - set consumed [dict get $assign_d consumed] - set resultlist [dict get $assign_d resultlist] - set newtypelist [dict get $assign_d typelist] - if {[tcl::dict::get $argstate $leadername -optional]} { - if {$consumed == 0} { - #error 111 - incr ldridx -1 - set leadername_multiple "" - incr nameidx - continue - } - } else { - #required named arg - if {$consumed == 0} { - if {$leadername ni $leadernames_received} { - #puts stderr "_get_dict_can_assign_value $ldridx $values $nameidx $VAL_NAMES" - set msg "Bad number of leaders for %caller%. Not enough remaining values to assign to required arguments (fail on $leadername)." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingrequiredleader $leadername ] -argspecs $argspecs]] $msg - } else { - #error 222 - incr ldridx -1 - set leadername_multiple "" - incr nameidx - continue - } - } - } - - if {[llength $leadertypelist] == 1} { - set clauseval $ldr - } else { - set clauseval $resultlist - incr ldridx [expr {$consumed - 1}] - tcl::dict::set argstate $leadername -type $newtypelist ;#(possible ?omitted-? and ?defaulted-? entries - } - - if {[tcl::dict::get $argstate $leadername -multiple]} { - #if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { - # #current stored ldr equals defined default - don't include default in the list we build up - # tcl::dict::set leaders_dict $leadername [list $clauseval] ;#important to treat first element as a list - #} else { - # tcl::dict::lappend leaders_dict $leadername $clauseval - #} - if {$leadername in $leadernames_received} { - tcl::dict::lappend leaders_dict $leadername $clauseval - } else { - tcl::dict::set leaders_dict $leadername [list $clauseval] - } - set leadername_multiple $leadername - } else { - tcl::dict::set leaders_dict $leadername $clauseval - set leadername_multiple "" - incr nameidx - } - lappend leadernames_received $leadername - } else { - if {$leadername_multiple ne ""} { - set leadertypelist [tcl::dict::get $argstate $leadername_multiple -type] - if {[llength $leadertypelist] == 1} { - set clauseval $ldr - } else { - set clauseval [list] - incr ldridx -1 - foreach t $leadertypelist { - incr ldridx - if {$ldridx > [llength $leaders]-1} { - set msg "Bad number of leaders for %caller%. Received [llength $clauseval] values ('$clauseval') for '$leadername_multiple', but requires up to [llength $leadertypelist] values." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength [llength $leadertypelist] ] -argspecs $argspecs]] $msg - } - lappend clauseval [lindex $leaders $ldridx] - } - } - tcl::dict::lappend leaders_dict $leadername_multiple $clauseval - #name already seen - but must add to leadernames_received anyway (as with opts and values) - lappend leadernames_received $leadername_multiple - } else { - if {$LEADER_UNNAMED} { - tcl::dict::set leaders_dict $positionalidx $ldr - tcl::dict::set argstate $positionalidx $LEADERSPEC_DEFAULTS - tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS - lappend leadernames_received $positionalidx - } else { - set msg "Bad number of leaders for %caller%. Received more leaders than can be assigned to argument names. (set '@leaders -unnamed true' to allow unnamed leaders)" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list toomanyarguments [llength $values] index $positionalidx] -argspecs $argspecs]] $msg - } - } - } - set positionalidx [expr {$start_position + $ldridx + 1}] - } - #----------------------------------------------------- - #satisfy test parse_withdef_leaders_no_phantom_default - foreach leadername [dict keys $leaders_dict] { - if {[string is integer -strict $leadername]} { - #ignore leadername that is a positionalidx - #review - always trailing - could use break? - continue - } - if {$leadername ni $leadernames_received && ![dict exists $LEADER_DEFAULTS $leadername]} { - #remove the name with empty-string default we used to establish fixed order of names - #The 'leaders' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default. - dict unset leaders_dict $leadername - } - } - #----------------------------------------------------- - - set validx 0 - set valname_multiple "" - set valnames_received [list] - - set num_values [llength $values] - #------------------------------------------ - #Establish firm values ordering - ## Don't set values_dict to VAL_DEFAULTS - or order of values_dict will be intermittently wrong based on whether values have defaults - ## set values_dict $val_defaults - set values_dict [dict create] - foreach valname [lrange $VAL_NAMES 0 $num_values-1] { - #set ALL valnames to lock in positioning - #note - later we need to unset any optional that had no default and was not received (no phantom default) - dict set values_dict $valname {} - } - set values_dict [dict merge $values_dict $VAL_DEFAULTS] - #------------------------------------------ - set nameidx 0 - set start_position $positionalidx - #MAINTENANCE - (*nearly*?) same loop logic as for leaders - for {set validx 0} {$validx < [llength $values]} {incr validx} { - set valname [lindex $VAL_NAMES $nameidx] - set val [lindex $values $validx] - if {$valname ne ""} { - set valtypelist [tcl::dict::get $argstate $valname -type] - - set assign_d [_get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES $valnames_received $formdict] - set consumed [dict get $assign_d consumed] - set resultlist [dict get $assign_d resultlist] - set newtypelist [dict get $assign_d typelist] - if {[tcl::dict::get $argstate $valname -optional]} { - if {$consumed == 0} { - incr validx -1 - set valname_multiple "" - incr nameidx - continue - } - } else { - #required named arg - if {$consumed == 0} { - if {$valname ni $valnames_received} { - #puts stderr "_get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES" - set msg "Bad number of values for %caller%. Not enough remaining values to assign to required arguments (fail on $valname)." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingrequiredvalue $valname ] -argspecs $argspecs]] $msg - } else { - incr validx -1 - set valname_multiple "" - incr nameidx - continue - } - } - } - #assert can_assign != 0, we have at least one value to assign to clause - - if {[llength $valtypelist] == 1} { - set clauseval $val - } else { - #clauseval must contain as many elements as the max length of -types! - #(empty-string/default for optional (?xxx?) clause members) - set clauseval $resultlist - #_get_dict_can_assign has only validated clause-length and literals match - #we assign and leave further validation for main validation loop. - incr validx [expr {$consumed -1}] - if {$validx > [llength $values]-1} { - error "get_dict unreachable" - set msg "Bad number of values for %caller%. Received [llength $clauseval] values for clause '$valname', but requires up to [llength $valtypelist] values." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength [llength $valtypelist] ] -argspecs $argspecs]] $msg - } - - tcl::dict::set argstate $valname -type $newtypelist ;#(possible ?omitted-? and ?defaulted-? entries - } - - if {[tcl::dict::get $argstate $valname -multiple]} { - #if {[tcl::dict::exists $VAL_DEFAULTS $valname]} { - # #current stored val equals defined default - don't include default in the list we build up - # tcl::dict::set values_dict $valname [list $clauseval] ;#important to treat first element as a list - #} else { - # tcl::dict::lappend values_dict $valname $clauseval - #} - if {$valname in $valnames_received} { - tcl::dict::lappend values_dict $valname $clauseval - } else { - tcl::dict::set values_dict $valname [list $clauseval] - } - set valname_multiple $valname - } else { - tcl::dict::set values_dict $valname $clauseval - set valname_multiple "" - incr nameidx - } - lappend valnames_received $valname - } else { - if {$valname_multiple ne ""} { - set valtypelist [tcl::dict::get $argstate $valname_multiple -type] - if {[llength $valname_multiple] == 1} { - set clauseval $val - } else { - set clauseval [list] - incr validx -1 - for {set i 0} {$i < [llength $valtypelist]} {incr i} { - incr validx - if {$validx > [llength $values]-1} { - set msg "Bad number of values for %caller%. Received [llength $clauseval] values for clause '$valname_multiple', but requires [llength $valtypelist] values." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength [llength $valtypelist] ] -argspecs $argspecs]] $msg - } - lappend clauseval [lindex $values $validx] - } - } - tcl::dict::lappend values_dict $valname_multiple $clauseval - #name already seen - but must add to valnames_received anyway (as with opts and leaders) - lappend valnames_received $valname_multiple - } else { - if {$VAL_UNNAMED} { - tcl::dict::set values_dict $positionalidx $val - tcl::dict::set argstate $positionalidx $VALSPEC_DEFAULTS - tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS - lappend valnames_received $positionalidx - } else { - set msg "Bad number of values for %caller%. Received more values than can be assigned to argument names. (set '@values -unnamed true' to allow unnamed values)" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list toomanyarguments [llength $values] index $positionalidx] -argspecs $argspecs]] $msg - } - } - } - set positionalidx [expr {$start_position + $validx + 1}] - } - #----------------------------------------------------- - #satisfy test parse_withdef_values_no_phantom_default - foreach vname [dict keys $values_dict] { - if {[string is integer -strict $vname]} { - #ignore vname that is a positionalidx - #review - always trailing - could break? - continue - } - if {$vname ni $valnames_received && ![dict exists $VAL_DEFAULTS $vname]} { - #remove the name with empty-string default we used to establish fixed order of names - #The 'values' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default. - dict unset values_dict $vname - } - } - #----------------------------------------------------- - - if {$leadermax == -1} { - #only check min - if {$num_leaders < $leadermin} { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected at least $leadermin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - } - } else { - if {$num_leaders < $leadermin || $num_leaders > $leadermax} { - if {$leadermin == $leadermax} { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected exactly $leadermin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - } else { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - } - } - } - - if {$valmax == -1} { - #only check min - if {$num_values < $valmin} { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $valmin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg - } - } else { - if {$num_values < $valmin || $num_values > $valmax} { - if {$valmin == $valmax} { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $valmin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg - } else { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $valmin and $valmax inclusive" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg - } - } - } - - #assertion - opts keys are full-length option names if -any|-arbitrary was false or if the supplied option as a shortname matched one of our defined options - - - #opts explicitly marked as -optional 0 must be present - regardless of -any|-arbitrary (which allows us to ignore additional opts to pass on to next call) - #however - if -any|-arbitrary 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 SHOULD? 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 - - #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? - #example timing difference: - #struct::set difference {x} {a b} - #normal interp 0.18 u2 vs safe interp 9.4us - #if {[llength [set missing [struct::set difference $OPT_REQUIRED $flagsreceived]]]} { - # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" - #} - #if {[llength [set missing [struct::set difference $VAL_REQUIRED $valnames_received]]]} { - # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" - #} - #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us - if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { - set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadermissing $missing received $leadernames_received] -argspecs $argspecs]] $msg - #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - set api_opt_required [lmap v $OPT_REQUIRED {lindex [split $v |] end}] - if {[llength [set missing [punklib_ldiff $api_opt_required $flagsreceived]]]} { - set full_missing [dict get $lookup_optset $missing] - set msg "Required option missing for %caller%. missing flags: '$full_missing' are marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list optionmissing $full_missing received $flagsreceived] -argspecs $argspecs]] $msg - #arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs - } - if {[llength [set missing [punklib_ldiff $VAL_REQUIRED $valnames_received]]]} { - set msg "Required value missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list valuemissing $missing received $valnames_received] -argspecs $argspecs]] $msg - #arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - - #--------------------------------------------------------------------------------------------- - #maintain order of opts $opts values $values as caller may use lassign. - set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] - if {[llength $receivednames]} { - #flat zip of names with overall posn, including opts - #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] - set i -1 - set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] - } else { - set received_posns [list] - } - #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) - #(e.g using 'dict exists $received -flag') - # - but it can have duplicate keys when args/opts have -multiple 1 - #It is actually a list of paired elements - #--------------------------------------------------------------------------------------------- - - - #todo - truncate/summarize values in error messages - - #todo - allow defaults outside of choices/ranges - - #check types,ranges,choices - set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] - #set combined_defaults [tcl::dict::merge $VAL_DEFAULTS $OPT_DEFAULTS] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash - #puts "---opts_and_values:$opts_and_values" - #puts "---argstate:$argstate" - tcl::dict::for {api_argname value_group} $opts_and_values { - if {[string match -* $api_argname]} { - #get full option name such as -fg|-foreground from non-alias name such as -foreground - #if "@opts -any|-arbitrary true" - we may have an option that wasn't defined - if {[dict exists $lookup_optset $api_argname]} { - set argname [dict get $lookup_optset $api_argname] - } else { - puts stderr "unable to find $api_argname in $lookup_optset" - } - } else { - set argname $api_argname - } - - set thisarg [tcl::dict::get $argstate $argname] - #set thisarg_keys [tcl::dict::keys $thisarg] - set thisarg_checks [tcl::dict::get $arg_checks $argname] - set is_multiple [tcl::dict::get $thisarg -multiple] - set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] - set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] - set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] - set has_default [tcl::dict::exists $thisarg -default] - if {$has_default} { - set defaultval [tcl::dict::get $thisarg -default] - } - set typelist [tcl::dict::get $thisarg -type] - set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] - set regexprepass [tcl::dict::get $thisarg -regexprepass] - set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 - set validationtransform [tcl::dict::get $thisarg -validationtransform] - - - #JJJJ - if {$is_multiple} { - set vlist $value_group - } else { - set vlist [list $value_group] - } - #JJJJ - if {[llength $typelist] == 1} { - set vlist [list $vlist] - } - set vlist_original $vlist ;#retain for possible final strip_ansi - - #review - validationtransform - if {$is_validate_ansistripped} { - #validate_ansistripped 1 - package require punk::ansi - set vlist_check [list] - foreach clause_value $vlist { - lappend vlist_check [punk::ansi::ansistrip $clause_value] - } - } else { - #validate_ansistripped 0 - set vlist_check $vlist - } - - switch -- [Dict_getdef $thisarg -ARGTYPE unknown] { - leader { - set dname leaders_dict - set argclass "Leading argument" - } - option { - set dname opts - set argclass Option - } - value { - set dname values_dict - set argclass "Trailing argument" - } - default { - set dname "_unknown_" ;#NA - set argclass "Unknown argument" - } - } - #reduce our validation requirements by removing values which match defaultval or match -choices - #(could be -multiple with -choicerestricted 0 where some selections match and others don't) - if {$api_argname in $receivednames && $has_choices} { - #-choices must also work with -multiple - #todo -choicelabels - set choiceprefix [tcl::dict::get $thisarg -choiceprefix] - set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] - set choiceprefixreservelist [Dict_getdef $thisarg -choiceprefixreservelist {}] - set choicerestricted [tcl::dict::get $thisarg -choicerestricted] - set choicemultiple [tcl::dict::get $thisarg -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set nocase [tcl::dict::get $thisarg -nocase] - set choices [Dict_getdef $thisarg -choices {}] - set choicegroups [Dict_getdef $thisarg -choicegroups {}] - set allchoices $choices - if {[dict size $choicegroups]} { - dict for {groupname groupmembers} $choicegroups { - lappend allchoices {*}$groupmembers - } - } - #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups - #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes - - - set idx 0 ;# - #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes - #assert llength $vlist == llength [dict get $dname $argname] - # (unless there was a default and the option wasn't specified) - set vlist_validate [list] - set vlist_check_validate [list] - foreach e $vlist e_check $vlist_check { - set allchoices_in_list 0 - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - #vlist and vlist_check can be list of lists if -multiple and -choicemultiple - #each e represents 0 or more choice selections - set c_list $e - set c_check_list $e_check - #todo? check if entire list matches default? - } else { - #only one choice at a time - ensure single entry in c_list c_check_list - set c_list [list $e] - set c_check_list [list $e_check] - } - - - #----------------------------------- - #fast fail on the wrong number of choices - if {[llength $c_list] < $choicemultiple_min} { - set msg "$argclass $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { - set msg "$argclass $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - #----------------------------------- - - set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list - foreach c $c_list c_check $c_check_list { - if {$nocase} { - set casemsg " (case insensitive)" - set choices_test [tcl::string::tolower $allchoices] - #Don't lcase the denylist - even in nocase mode! - #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] - set v_test [tcl::string::tolower $c_check] - } else { - set casemsg " (case sensitive)" - set v_test $c_check - set choices_test $allchoices - } - set choice_in_list 0 - set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? - if {!$matches_default} { - if {$choiceprefix} { - #can we handle empty string as a choice? It should just work - REVIEW/test - set choice_exact_match 0 - if {$c_check in $allchoices} { - #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing - set chosen $c_check - set choice_in_list 1 - set choice_exact_match 1 - } elseif {$v_test in $choices_test} { - #assert - if we're here, nocase must be true - #we know choice is present as full-length match except for case - #now we want to select the case from the choice list - not the supplied value - #we don't set choice_exact_match - because we will need to override the optimistic existing val below - #review - foreach avail [lsort -unique $allchoices] { - if {[string match -nocase $c $avail]} { - set chosen $avail - } - } - #assert chosen will always get set - set choice_in_list 1 - } else { - #puts ">>>> choiceprefixreservelist: $choiceprefixreservelist" - #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. - #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. - #in this block we can treat empty result from prefix match as a non-match - if {$nocase} { - #nocase implies that our entered value doesn't have to match case of choices - - #but we would still like to select the best match if there are case-dups. - #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete - # selecting Del will find Delete, del will match delete (and raise error) - # but DEL will also match delete rather than Delete - so again an error is raised. - #This is counterintuitive with -nocase - #This is probably such an edge case that best served with documentation as a feature-not-bug - #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? - #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. - - set bestmatch [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check] - if {$bestmatch eq "" || $bestmatch in $choiceprefixreservelist} { - set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $choices_test] {*}$choiceprefixreservelist] $v_test] - #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing - set chosen [lsearch -inline -nocase $allchoices $chosen] - set choice_in_list [expr {$chosen ne ""}] - } else { - set chosen $bestmatch - set choice_in_list 1 - } - } else { - set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check] - if {$chosen eq "" || $chosen in $choiceprefixreservelist} { - set choice_in_list 0 - } else { - set choice_in_list 1 - } - } - #override choice_in_list if in deny list - #don't allow prefixing for elements from -choiceprefixdenylist - #we still use all elements to calculate the prefixes though - #review - case difference edge cases in choiceprefixdenylist !todo - if {$chosen in $choiceprefixdenylist} { - set choice_in_list 0 - set chosen "" - } - } - - #override the optimistic existing val - if {$choice_in_list && !$choice_exact_match} { - if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { - if {$is_multiple} { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $idx $chosen - tcl::dict::set $dname $argname $existing - } else { - tcl::dict::set $dname $argname $chosen - } - } else { - if {$is_multiple} { - set existing_all [tcl::dict::get [set $dname] $argname] - lset existing_all $idx $choice_idx $chosen - tcl::dict::set $dname $argname $existing_all - } else { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $choice_idx $chosen - tcl::dict::set $dname $argname $existing - } - } - } - } else { - #value as stored in $dname is ok - set choice_in_list [expr {$v_test in $choices_test}] - } - } - - if {!$choice_in_list && !$matches_default} { - if {!$choicerestricted} { - #if {$is_multiple} { - # set existing [tcl::dict::get [set $dname] $argname] - # lset existing $idx $v_test - # tcl::dict::set $dname $argname $existing - #} else { - # tcl::dict::set $dname $argname $v_test - #} - lappend vlist_validate $c - lappend vlist_check_validate $c_check - } else { - #unhappy path - if {$choiceprefix} { - set prefixmsg " (or a unique prefix of a value)" - } else { - set prefixmsg "" - } - #review: $c vs $c_check for -badval? - set msg "$argclass '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname - } - } - incr choice_idx - } - - incr idx - } - #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation - #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - - #todo - don't add to validation lists if not in receivednames - #if we have an optionset such as "-f|-x|-etc" api_argname is -etc - if {$api_argname ni $receivednames} { - set vlist [list] - set vlist_check_validate [list] - } else { - if {[llength $vlist] && $has_default} { - #defaultval here is a value for the clause. - set vlist_validate [list] - set vlist_check_validate [list] - foreach clause_value $vlist clause_check $vlist_check { - #JJJJ - #argname - #thisarg - set tp [dict get $thisarg -type] - if {[llength $tp] == 1} { - if {$clause_value ni $vlist_validate} { - #for -choicemultiple with default that could be a list use 'ni' ?? review - if {[lindex $clause_check 0] ne $defaultval} { - lappend vlist_validate $clause_value - lappend vlist_check_validate $clause_check - } - } - } else { - if {$clause_value ni $vlist_validate} { - if {$clause_check ne $defaultval} { - lappend vlist_validate $clause_value - lappend vlist_check_validate $clause_check - } - } - } - #Todo? - #else ??? - } - set vlist $vlist_validate - set vlist_check $vlist_check_validate - } - } - - #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups - #assert: our vlist & vlist_check lists have been reduced to remove those - if {[llength $vlist] && !$is_allow_ansi} { - #allow_ansi 0 - package require punk::ansi - #do not run ta::detect on a list - foreach clause_value $vlist { - foreach e $clause_value { - if {[punk::ansi::ta::detect $e]} { - set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - #puts "argname:$argname v:$v is_default:$is_default" - #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. - #arguments that are at their default are not subject to type and other checks - - #don't validate defaults or choices that matched - #puts "---> opts_and_values: $opts_and_values" - #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" - #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} - - #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups - #assert [llength $vlist] == [llength $vlist_check] - if {[llength $vlist]} { - for {set t 0} {$t < [llength $typelist]} {incr t} { - set typespec [lindex $typelist $t] - set type [string trim $typespec ?] - #puts "$argname - switch on type: $type" - switch -- $type { - any {} - literal { - foreach clause_value $vlist { - set e [lindex $clause_value $t] - if {$e ne $argname} { - set msg "$argclass '$argname' for %caller% requires literal value '$argname'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - } - } - } - list { - foreach clause_value $vlist_check { - set e_check [lindex $clause_value $t] - if {![tcl::string::is list -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg - } - if {[tcl::dict::size $thisarg_checks]} { - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[llength $e_check] < $checkval} { - set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[llength $e_check] > $checkval} { - set msg "$argclass '$argname for %caller% requires list with -maxsize $checkval. Received len:[llength $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg - } - } - } - } - } - } - } - } - indexexpression { - foreach clause_value $vlist_check { - set e_check [lindex $clause_value $t] - if {[catch {lindex {} $e_check}]} { - set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - string - ansistring - globstring { - #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string - #we possibly don't want to always have to regex on things that don't pass the other more basic checks - # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) - # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) - # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead - # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function - # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) - # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail - - #todo? - way to validate both unstripped and stripped? - set pass_quick_list_e [list] - set pass_quick_list_e_check [list] - set remaining_e $vlist - set remaining_e_check $vlist_check - #review - order of -regexprepass and -regexprefail in original rawargs significant? - #for now -regexprepass always takes precedence - if {$regexprepass ne ""} { - foreach clauseval $vlist clauseval_check $vlist_check { - set e [lindex $clauseval $t] - set e_check [lindex $clauseval_check $t] - if {[regexp [lindex $regexprepass $t] $e]} { - lappend pass_quick_list_e $clauseval - lappend pass_quick_list_e_check $clauseval_check - } - } - set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] - set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] - } - if {$regexprefail ne ""} { - foreach clauseval $remaining_e clauseval_check $remaining_e_check { - set e [lindex $clauseval $t] - set e_check [lindex $clauseval_check $t] - #puts "----> checking $e vs regex $regexprefail" - if {[regexp $regexprefail $e]} { - if {[tcl::dict::exists $thisarg -regexprefailmsg]} { - #review - %caller% ?? - set msg [tcl::dict::get $thisarg -regexprefailmsg] - } else { - set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" - } - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - switch -- $type { - ansistring { - #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi - #.. so we need to look at the original values in $vlist not $vlist_check - - #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? - #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? - package require punk::ansi - foreach clauseval $remaining_e { - set e [lindex $clauseval $t] - if {![punk::ansi::ta::detect $e]} { - set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - globstring { - foreach clauseval $remaining_e { - set e [lindex $clauseval $t] - if {![regexp {[*?\[\]]} $e]} { - set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - - if {[tcl::dict::size $thisarg_checks]} { - foreach clauseval $remaining_e_check { - set e_check [lindex $clauseval $t] - if {[dict exists $thisarg_checks -minsize]} { - set minsize [dict get $thisarg_checks -minsize] - # -1 for disable is as good as zero - if {[tcl::string::length $e_check] < $minsize} { - set msg "$argclass '$argname' for %caller% requires string with -minsize $minsize. Received len:[tcl::string::length $e_check] value:'$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - if {[dict exists $thisarg_checks -maxsize]} { - set maxsize [dict get $thisarg_checks -maxsize] - if {$checkval ne "-1"} { - if {[tcl::string::length $e_check] > $maxsize} { - set msg "$argclass '$argname' for %caller% requires string with -maxsize $maxsize. Received len:[tcl::string::length $e_check] value:'$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - } - number { - #review - consider effects of Nan and Inf - #NaN can be considered as 'technically' a number (or at least a special numeric value) - foreach clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} { - set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - if {[tcl::dict::exists $thisarg -typeranges]} { - set ranges [tcl::dict::get $thisarg -typeranges] - foreach clauseval $vlist clauseval_check $vlist_check { - set e [lindex $clauseval $t] - set e_check [lindex $clauseval_check $t] - set range [lindex $ranges $t] - lassign {} low high ;#set both empty - lassign $range low high - - if {"$low$high" ne ""} { - if {[::tcl::mathfunc::isnan $e]} { - set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - if {$low eq ""} { - if {$e_check > $high} { - set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } elseif {$high eq ""} { - if {$e_check < $low} { - set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } else { - if {$e_check < $low || $e_check > $high} { - set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - } - int { - #elements in -typeranges can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive - foreach clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - if {[tcl::dict::exists $thisarg -typeranges]} { - set ranges [tcl::dict::get $thisarg -typeranges] - foreach clauseval $vlist clauseval_check $vlist_check { - set e [lindex $clauseval $t] - set e_check [lindex $clauseval_check $t] - set range [lindex $ranges $t] - lassign $range low high - if {"$low$high" ne ""} { - if {$low eq ""} { - #lowside unspecified - check only high - if {$e_check > $high} { - set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } elseif {$high eq ""} { - #highside unspecified - check only low - if {$e_check < $low} { - set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } else { - #high and low specified - if {$e_check < $low || $e_check > $high} { - set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - } - double { - foreach clauseval $vlist clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - if {![tcl::string::is double -strict $e_check]} { - set e [lindex $clauseval $t] - set msg "$argclass $argname for %caller% requires type double. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - if {[tcl::dict::size $thisarg_checks]} { - if {[dict exists $thisarg_checks -typeranges]} { - set ranges [dict get $thisarg_checks -typeranges] - foreach clauseval $vlist clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - set range [lindex $ranges $t] - #todo - small-value double comparisons with error-margin? review - #todo - empty string for low or high - lassign $range low high - if {$e_check < $low || $e_check > $high} { - set e [lindex $clauseval $t] - set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - } - bool { - foreach clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - if {![tcl::string::is boolean -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - dict { - foreach clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - if {[llength $e_check] %2 != 0} { - set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - } - if {[tcl::dict::size $thisarg_checks]} { - if {[dict exists $thisarg_checks -minsize]} { - set minsizes [dict get $thisarg_checks -minsize] - foreach clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - set minsize [lindex $minsizes $t] - # -1 for disable is as good as zero - if {[tcl::dict::size $e_check] < $minsize} { - set msg "$argclass '$argname' for %caller% requires dict with -minsize $minsize. Received dict size:[dict size $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - } - } - if {[dict exists $thisarg_checks -maxsize]} { - set maxsizes [dict get $thisarg_checks -maxsize] - foreach clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - set maxsize [lindex $maxsizes $t] - if {$maxsize ne "-1"} { - if {[tcl::dict::size $e_check] > $maxsize} { - set msg "$argclass '$argname' for %caller% requires dict with -maxsize $maxsize. Received dict size:[dict size $e_check]" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - } - } - } - } - } - } - alnum - - alpha - - ascii - - control - - digit - - graph - - lower - - print - - punct - - space - - upper - - wordchar - - xdigit { - foreach clauseval $vlist clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - if {![tcl::string::is $type -strict $e_check]} { - set e [lindex $clauseval $t] - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - file - - directory - - existingfile - - existingdirectory { - foreach e $vlist e_check $vlist_check { - #//review - we may need '?' char on windows - if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { - #what about special file names e.g on windows NUL ? - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - } - } - if {$type eq "existingfile"} { - foreach e $vlist e_check $vlist_check { - if {![file exists $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } elseif {$type eq "existingdirectory"} { - foreach e $vlist e_check $vlist_check { - if {![file isdirectory $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } - } - char { - #review - char vs unicode codepoint vs grapheme? - foreach clauseval $vlist clauseval_check $vlist_check { - set e_check [lindex $clauseval_check $t] - if {[tcl::string::length $e_check] != 1} { - set e [lindex $clauseval $t] - set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - } - } - } - } - - } - - - } - - if {$is_strip_ansi} { - set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach - if {[tcl::dict::get $thisarg -multiple]} { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict $argname $stripped_list - } - option { - tcl::dict::set opts $argname $stripped_list - } - value { - tcl::dict::set values_dict $argname $stripped_list - } - } - } else { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict [lindex $stripped_list 0] - } - option { - tcl::dict::set opts $argname [lindex $stripped_list 0] - } - value { - tcl::dict::set values_dict [lindex $stripped_list 0] - } - } - } - } - } - - return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns solos $solosreceived multis $multisreceived] - } - - - proc forms {id} { - set spec [get_spec $id] - if {[dict size $spec]} { - return [dict get $spec form_names] - } else { - return [list] - } - } - lappend PUNKARGS [list { - @id -id ::punk::args::synopsis - @cmd -name punk::args::synopsis -help\ - "Return synopsis for each form of a command id - on separate lines. - If -form is given, supply only - the synopsis for that form. - " - @opts - -form -type string -default * - -return -type string -default full -choices {full summary dict} - @values -min 1 -max -1 - cmditem -multiple 1 -optional 0 - }] - proc synopsis {args} { - set argd [punk::args::parse $args withid ::punk::args::synopsis] - - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - if {$has_punkansi} { - set I [punk::ansi::a+ italic] - set NI [punk::ansi::a+ noitalic] - #set RST [punk::ansi::a] - set RST "\x1b\[m" - } else { - set I "" - set NI "" - set RST "" - } - - ##set form * - ##if {[lindex $args 0] eq "-form"} { - ## set arglist [lrange $args 2 end] - ## set form [lindex $args 1] - ##} else { - ## set arglist $args - ##} - ##if {[llength $arglist] == 0} { - ## error "punk::args::synopsis expected command id possibly with trailing subcommands/args" - ##} - ##set id [lindex $arglist 0] - ##set cmdargs [lrange $arglist 1 end] - - lassign [dict values $argd] leaders opts values - set form [dict get $opts -form] - set opt_return [dict get $opts -return] - set cmditems [dict get $values cmditem] - set id [lindex $cmditems 0] - set cmdargs [lrange $cmditems 1 end] - - - set spec [get_spec $id] - if {$spec eq ""} { - return - } - set form_names [dict get $spec form_names] - if {$form ne "*"} { - if {[string is integer -strict $form]} { - set f [lindex $form_names $form] - if {$f ne ""} { - set form_names [list $f] - } else { - set form_names [list] - } - } else { - if {$form in $form_names} { - set form_names [list $form] - } else { - set form_names [list] - } - } - } - - set SYND [dict create] - set syn "" - #todo - -multiple etc - foreach f $form_names { - set SYNLIST [list] - dict set SYND $f [list] - append syn "$id" - set forminfo [dict get $spec FORMS $f] - #foreach argname [dict get $forminfo LEADER_NAMES] { - # set arginfo [dict get $forminfo ARG_INFO $argname] - # set ARGD [dict create argname $argname class leader] - # if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - # set display [lindex [dict get $arginfo -choices] 0] - # } elseif {[dict get $arginfo -type] eq "literal"} { - # set display $argname - # } else { - # set display $I$argname$RST - # } - # if {[dict get $arginfo -optional]} { - # append syn " ?$display?" - # } else { - # append syn " $display" - # } - # dict set ARGD type [dict get $arginfo -type] - # dict set ARGD optional [dict get $arginfo -optional] - # dict set ARGD display $display - # dict lappend SYND $f $ARGD - #} - foreach argname [dict get $forminfo LEADER_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set typelist [dict get $arginfo -type] - if {[llength $typelist] == 1} { - set tp [lindex $typelist 0] - if {[dict exists $arginfo -typesynopsis]} { - #set arg_display [dict get $arginfo -typesynopsis] - set clause [dict get $arginfo -typesynopsis] - } else { - #set arg_display $argname - if {$tp eq "literal"} { - set clause [lindex $argname end] - } elseif {[string match literal(*) $tp]} { - set match [string range $tp 8 end-1] - set clause $match - } else { - set clause $I$argname$NI - } - } - } else { - set n [expr {[llength $typelist]-1}] - set name_tail [lrange $argname end-$n end];#if there are enough tail words in the argname to match -types - set clause "" - if {[dict exists $arginfo -typesynopsis]} { - set tp_displaylist [dict get $arginfo -typesynopsis] - } else { - set tp_displaylist [lrepeat [llength $typelist] ""] - } - - foreach typespec $typelist td $tp_displaylist elementname $name_tail { - #elementname will commonly be empty - if {[string match {\?*\?} $typespec]} { - set tp [string range $typespec 1 end-1] - set member_optional 1 - } else { - set tp $typespec - set member_optional 0 - } - if {$tp eq "literal"} { - set c $elementname - } elseif {[string match literal(*) $tp]} { - set match [string range $tp 8 end-1] - set c $match - } else { - if {$td eq ""} { - set c $I$tp$NI - } else { - set c $td - } - } - if {$member_optional} { - append clause " " "(?$c?)" - } else { - append clause " " $c - } - } - set clause [string trimleft $clause] - } - - set ARGD [dict create argname $argname class leader] - if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} { - if {[dict get $arginfo -multiple]} { - #set display "?$I$argname$NI?..." - set display "?$clause?..." - } else { - set display "?$clause?" - #if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - # set display "?[lindex [dict get $arginfo -choices] 0]?" - #} elseif {[dict get $arginfo -type] eq "literal"} { - # set display "?$argname?" - #} else { - # set display "?$I$argname$NI?" - #} - } - } else { - if {[dict get $arginfo -multiple]} { - #set display "$I$argname$NI ?$I$argname$NI?..." - set display "$clause ?$clause?..." - } else { - set display $clause - #if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - # set display "[lindex [dict get $arginfo -choices] 0]" - #} elseif {[dict get $arginfo -type] eq "literal"} { - # set display $argname - #} else { - # set display "$I$argname$NI" - #} - } - } - append syn " $display" - dict set ARGD type [dict get $arginfo -type] - dict set ARGD optional [dict get $arginfo -optional] - dict set ARGD display $display - dict lappend SYND $f $ARGD - } - foreach argname [dict get $forminfo OPT_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set ARGD [dict create argname $argname class option] - set tp [dict get $arginfo -type] - if {[dict exists $arginfo -typesynopsis]} { - set tp_display [dict get $arginfo -typesynopsis] - } else { - #set tp_display "<$tp>" - set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first) - foreach tp_member [split $tp |] { - #-type literal not valid for opt - review - if {[string match literal(*) $tp_member]} { - set match [string range $tp_member 8 end-1] - lappend alternates $match - } elseif {[string match literalprefix(*) $tp_member]} { - set match [string range $tp_member 14 end-1] - lappend alternates $match - } else { - lappend alternates $I<$tp_member>$NI - } - } - #todo - trie prefixes display? - set alternates [punk::args::lib::lunique $alternates] - set tp_display [join $alternates |] - } - - if {[dict get $arginfo -optional]} { - if {[dict get $arginfo -multiple]} { - if {$tp eq "none"} { - set display "?$argname?..." - } else { - set display "?$argname $tp_display?..." - } - } else { - if {$tp eq "none"} { - set display "?$argname?" - } else { - set display "?$argname $tp_display?" - } - } - } else { - if {[dict get $arginfo -multiple]} { - if {$tp eq "none"} { - set display "$argname ?$argname...?" - } else { - set display "$argname $tp_display ?$argname $tp_display?..." - } - } else { - if {$tp eq "none"} { - set display $argname - } else { - set display "$argname $tp_display" - } - } - } - append syn " $display" - dict set ARGD type [dict get $arginfo -type] - dict set ARGD optional [dict get $arginfo -optional] - dict set ARGD display $display - dict lappend SYND $f $ARGD - } - foreach argname [dict get $forminfo VAL_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set typelist [dict get $arginfo -type] - if {[llength $typelist] == 1} { - set tp [lindex $typelist 0] - if {[dict exists $arginfo -typesynopsis]} { - #set arg_display [dict get $arginfo -typesynopsis] - set clause [dict get $arginfo -typesynopsis] - } else { - #set arg_display $argname - set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first) - foreach tp_member [split $tp |] { - if {$tp_member eq "literal"} { - lappend alternates [lindex $argname end] - } elseif {[string match literal(*) $tp_member]} { - set match [string range $tp_member 8 end-1] - lappend alternates $match - } elseif {[string match literalprefix(*) $tp_member]} { - set match [string range $tp_member 14 end-1] - lappend alternates $match - } else { - lappend alternates $I$argname$NI - } - } - #remove dupes - but keep order (e.g of dupes -type string|int when no -typesynopsis was specified) - #todo - trie prefixes display - set alternates [punk::args::lib::lunique $alternates] - set clause [join $alternates |] - } - } else { - set n [expr {[llength $typelist]-1}] - set name_tail [lrange $argname end-$n end];#if there are enough tail words in the argname to match -types - set clause "" - if {[dict exists $arginfo -typesynopsis]} { - set tp_displaylist [dict get $arginfo -typesynopsis] - } else { - set tp_displaylist [lrepeat [llength $typelist] ""] - } - - foreach typespec $typelist td $tp_displaylist elementname $name_tail { - #elementname will commonly be empty - if {[string match {\?*\?} $typespec]} { - set tp [string range $typespec 1 end-1] - set member_optional 1 - } else { - set tp $typespec - set member_optional 0 - } - #handle alternate-types e.g literal(text)|literal(binary) - set alternates [list] - foreach tp_member [split $tp |] { - if {$tp_member eq "literal"} { - lappend alternates $elementname - } elseif {[string match literal(*) $tp_member]} { - set match [string range $tp_member 8 end-1] - lappend alternates $match - } elseif {[string match literalprefix(*) $tp_member]} { - set match [string range $tp_member 14 end-1] - lappend alternates $match - } else { - if {$td eq ""} { - lappend alternates $I$tp$NI - } else { - lappend alternates $td - } - } - } - set alternates [punk::args::lib::lunique $alternates] - set c [join $alternates |] - if {$member_optional} { - append clause " " "(?$c?)" - } else { - append clause " " $c - } - } - set clause [string trimleft $clause] - } - - set ARGD [dict create argname $argname class value] - if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} { - if {[dict get $arginfo -multiple]} { - #set display "?$I$argname$NI?..." - set display "?$clause?..." - } else { - set display "?$clause?" - #if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - # set display "?[lindex [dict get $arginfo -choices] 0]?" - #} elseif {[dict get $arginfo -type] eq "literal"} { - # set display "?$argname?" - #} else { - # set display "?$I$argname$NI?" - #} - } - } else { - if {[dict get $arginfo -multiple]} { - #set display "$I$argname$NI ?$I$argname$NI?..." - set display "$clause ?$clause?..." - } else { - set display $clause - #if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - # set display "[lindex [dict get $arginfo -choices] 0]" - #} elseif {[dict get $arginfo -type] eq "literal"} { - # set display $argname - #} else { - # set display "$I$argname$NI" - #} - } - } - append syn " $display" - dict set ARGD type [dict get $arginfo -type] - dict set ARGD optional [dict get $arginfo -optional] - dict set ARGD display $display - dict lappend SYND $f $ARGD - } - append syn \n - } - switch -- $opt_return { - full { - return [string trim $syn \n] - } - summary { - set summary "" - showdict $SYND - dict for {form arglist} $SYND { - append summary $id - set class_state leader - set option_count 0 - set value_count 0 - foreach ainfo $arglist { - switch -- [dict get $ainfo class] { - leader { - append summary " [dict get $ainfo display]" - } - option { - incr option_count - } - value { - incr value_count - if {$class_state ne "value"} { - if {$option_count > 0} { - append summary " ?options ($option_count defined)?" - } - set class_state value - } - append summary " [dict get $ainfo display]" - } - } - } - if {$value_count == 0 && $option_count > 0} { - append summary " ?options ($option_count defined)?" - } - append summary \n - } - set summary [string trim $summary \n] - return $summary - } - dict { - return $SYND - } - } - } - - - lappend PUNKARGS [list { - @id -id ::punk::args::synopsis_summary - @cmd -name punk::args::synopsis_summary -help\ - "Reduce the width of a synopsis string - by coalescing options to ?options?... - synopsis string may be arbitrarily marked - up with ANSI codes." - @opts - @values -min 1 -max -1 - synopsis -multiple 0 -optional 0 - }] - proc synopsis_summary {args} { - set argd [punk::args::parse $args withid ::punk::args::synopsis_summary] - set synopsis [dict get $argd values synopsis] - set summary "" - foreach sline [split $synopsis \n] { - set sline [regsub -all {\s+} $sline " "] ;#normalize to single spacing only - review - set in_opt 0 - set line_out "" - set codestack [list] - set parts [punk::ansi::ta::split_codes_single $sline] - #basic - foreach {pt code} $parts { - set charlist [split $pt ""] - for {set i 0} {$i < [llength $charlist]} {incr i} { - set c [lindex $charlist $i] - - switch -- $c { - ? { - if {!$in_opt} { - set in_opt 1 - } else { - - } - } - " " { - if {!$in_opt} { - append line_out " " - } else { - set in_opt - } - } - default { - if {!$in_opt} { - append line_out $c - } - } - } - } - if {$code ne ""} { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set codestack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set codestack [list $code] - } elseif {[punk::ansi::codetype::is_sgr $code]} { - #basic simplification first - remove straight dupes - set dup_posns [lsearch -all -exact $codestack $code] ;#must be -exact because of square-bracket glob chars - set codestack [lremove $codestack {*}$dup_posns] - lappend codestack $code - } else { - #? ignore other ANSI codes? - } - } - } - if {[string match -* $plain_s] || [string match ?- $plain_s]} { - } - } - return $summary - } - - lappend PUNKARGS [list { - @id -id ::punk::args::TEST - @opts -optional 0 - -o1 -default 111 -help "opt 1 mandatory" - @opts -optional 1 - -o2 -default 222 -help "opt 2 optional" - @values -min 0 -max 1 - v -help\ - "v1 optional" - }] - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::lib { - variable PUNKARGS - tcl::namespace::export * - tcl::namespace::path [list [tcl::namespace::parent]] - #*** !doctools - #[subsection {Namespace punk::args::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 flatzip {l1 l2} { - concat {*}[lmap a $l1 b $l2 {list $a $b}] - } - - if {[info commands lseq] ne ""} { - #tcl 8.7+ lseq significantly faster, especially for larger ranges - #The internal rep can be an 'arithseries' with no string representation - proc zero_based_posns {count} { - if {$count < 1} {return} - lseq 0 $count-1 - } - } else { - proc zero_based_posns {count} { - if {$count < 1} {return} - lsearch -all [lrepeat $count 0] * - } - } - - #return list of single column-width marks - possibly with ansi - proc choiceinfo_marks {choice choiceinfodict} { - set marks [list] - if {[dict exists $choiceinfodict $choice]} { - set cinfo [dict get $choiceinfodict $choice] - foreach info $cinfo { - if {[lindex $info 0] eq "doctype"} { - switch -- [lindex $info 1] { - punkargs { - lappend marks [punk::ns::Cmark punkargs brightgreen] - } - ensemble { - lappend marks [punk::ns::Cmark ensemble brightyellow] - } - oo { - lappend marks [punk::ns::Cmark oo brightcyan] - } - ooc { - lappend marks [punk::ns::Cmark ooc cyan] - } - ooo { - lappend marks [punk::ns::Cmark ooo cyan] - } - native { - lappend marks [punk::ns::Cmark native] - } - unknown { - lappend marks [punk::ns::Cmark unknown brightred] - } - } - } - } - } - return $marks - } - - - #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 -1] in calling scope ${[lindex [set x] 0]} !} - lappend PUNKARGS [list { - @id -id ::punk::args::lib::tstr - @cmd -name punk::args::lib::tstr -help\ - "A rough equivalent of js template literals - - Substitutions: - \$\{$varName\} - \$\{[myCommand]\} - (when -allowcommands flag is given)" - -allowcommands -default 0 -type none -help\ - "If -allowcommands is present, placeholder can contain commands - e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" - -undent -default 1 -type boolean -help\ - "undent/dedent the template lines. - The longest common prefix of whitespace is removed" - -indent -default "" -type string -help\ - "String with which to indent the template - prior to substitution. - If -undent is enabled, that is performed - first, then the indent is applied." - -paramindents -default line -choices {none line position} -choicelabels { - line\ - " Use leading whitespace in - the line in which the - placeholder occurs." - position\ - " Use the position in - the line in which the - placeholder occurs." - none\ - " No indents applied to - subsequent placeholder value - lines. This will usually - result in text awkwardly - ragged unless the source code - has also been aligned with the - left margin or the value has - been manually padded." - } -help\ - "How indenting is done for subsequent lines in a - multi-line placeholder substitution value. - The 1st line or a single line value is always - placed at the placeholder. - paramindents are performed after the main - template has been indented/undented. - (indenting by position does not calculate - unicode double-wide or grapheme cluster widths) - " - #choicelabels indented by 1 char is clearer for -return string - and reasonable in table - -return -default string -choices {dict list string args}\ - -choicelabels { - dict\ - " Return a dict with keys - 'template', 'params' and - 'errors'" - string\ - " Return a single result - being the string with - placeholders substituted." - list\ - " Return a 2 element list. - The first is itself a list - of plaintext portions of the - template, split at each point - at which placeholders were - present. The second element - of the outer list is a list - of placeholder values if -eval - is 1, or a list of the raw - placeholder strings if -eval - is 0." - args\ - " Return a list where the first - element is a list of template - plaintext sections as per the - 'list' return mechanism, but the - placeholder items are individual - items in the returned list. - This can be useful when passing - the expanded result of a tstr - command to another function - which expects the placeholders - as individual arguments" - } - -eval -default 1 -type boolean -help\ - "Whether to evaluate the \$\{\} placeholders. - When -return is string, -eval should generally be set to 1. - For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. - contained variables in that case should be braced or whitespace separated, or the variable - name is likely to collide with surrounding text. - e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" - @values -min 0 -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 - e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} - - Escape sequences such as \\n and unicode escapes are processed within placeholders. - " - }] - - proc tstr {args} { - #Too hard to fully eat-our-own-dogfood from within punk::args package - # - we use punk::args within the unhappy path only - #set argd [punk::args::get_by_id ::punk::lib::tstr $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 opt_eval [dict get $argd opts -eval] - - set templatestring [lindex $args end] - set arglist [lrange $args 0 end-1] - set opts [dict create\ - -allowcommands 0\ - -undent 1\ - -indent ""\ - -paramindents line\ - -eval 1\ - -return string\ - ] - if {"-allowcommands" in $arglist} { - set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] - dict set opts -allowcommands 1 - } - if {[llength $arglist] % 2 != 0} { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr expected option/value pairs prior to last argument" - } - } - dict for {k v} $arglist { - set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] - switch -- $fullk { - -indent - -undent - -paramindents - -return - -eval { - dict set opts $fullk $v - } - default { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" - } - } - } - } - set opt_allowcommands [dict get $opts -allowcommands] - set opt_paramindents [dict get $opts -paramindents] - set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] - if {$test_paramindents ni {none line position}} { - error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." - } - set opt_paramindents $test_paramindents - set opt_return [dict get $opts -return] - set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] - if {$opt_return eq ""} { - } - set opt_eval [dict get $opts -eval] - - - set nocommands "-nocommands" - if {$opt_allowcommands == 1} { - set nocommands "" - } - - set opt_undent [dict get $opts -undent] - if {$opt_undent} { - set templatestring [punk::args::lib::undent $templatestring] - } - set opt_indent [dict get $opts -indent] - if {$opt_indent ne ""} { - set templatestring [punk::args::lib::indent $templatestring $opt_indent] - } - - #set parts [_tstr_split $templatestring] - if {[string first \$\{ $templatestring] < 0} { - set parts [list $templatestring] - } else { - set parts [_parse_tstr_parts $templatestring] - } - set textchunks [list] - #set expressions [list] - set params [list] - set idx 0 - set errors [dict create] - set lastline "" ;#todo - first line has placeholder? - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach {pt expression} $parts { - lappend textchunks $pt - incr idx ;#pt incr - - #ignore last expression - if {$idx == [llength $parts]} { - break - } - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - #lappend expressions $expression - #---------------------- - #REVIEW - JMN - #TODO - debug punk::args loading of @dynamic defs - #puts "-- $expression" - #---------------------- - #brk1 - literal newline not {\n} - set leader "" - if {[set brk1 [string first \n $expression]] >= 0} { - #undent left of paramstart only for lines of expression that arent on opening ${..} line - set tail [string range $expression $brk1+1 end] - set leader [string repeat " " [string length $lastline]] - set undentedtail [punk::args::lib::undentleader $tail $leader] - #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] - set expression "[string range $expression 0 $brk1]$undentedtail" - } - if {$opt_eval} { - if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { - lappend params [string cat \$\{ $expression \}] - dict set errors [expr {[llength $params]-1}] $result - } else { - set result [string map [list \n "\n$leader"] $result] - lappend params $result - } - #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] - } else { - #JJJ - #REVIEW - #lappend params [subst -nocommands -novariables $expression] - lappend params $expression - } - append lastline [lindex $params end] ;#for current expression's position calc - - incr idx ;#expression incr - } - - if {$opt_return eq "dict"} { - return [dict create template $textchunks params $params errors $errors] - } - if {[dict size $errors]} { - set einfo "" - dict for {i e} $errors { - append einfo "parameter $i error: $e" \n - } - #REVIEW!!! - #TODO - fix - #puts stderr "tstr errors:\n$einfo\n" - } - - switch -- $opt_return { - list { - return [list $textchunks $params] - } - args { - #see example in tstr_test_one - return [list $textchunks {*}$params] - } - string { - #todo - flag to disable indent-matching behaviour for multiline param? - set out "" - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach pt $textchunks param $params { - if {$opt_paramindents eq "none"} { - append out $pt $param - } else { - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - if {$opt_paramindents eq "line"} { - regexp {(\s*).*} $lastline _all lastindent - } else { - #position - #TODO - detect if there are grapheme clusters - #This regsub doesn't properly space unicode double-wide chars or clusters - set lastindent "[regsub -all {\S} $lastline " "] " - } - if {$lastindent ne ""} { - set paramlines [split $param \n] - if {[llength $paramlines] == 1} { - append out $pt $param - } else { - append out $pt [lindex $paramlines 0] - foreach nextline [lrange $paramlines 1 end] { - append out \n $lastindent $nextline - } - } - } else { - append out $pt $param - } - append lastline $param - } - } - return $out - } - } - } - #test single placeholder tstr args where single placeholder must be an int - proc tstr_test_one {args} { - set argd [punk::args::parse $args withdef { - @cmd -name ::punk::args::lib::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 -return args {Select * from table where id = \$\{$id\} and etc... ;}] - } - - @values -min 2 -max 2 - template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - - but the tstr call in the example 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} - }] - 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]] ""] - set result [string cat [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 dollar sign - 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]] - } - - #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. - proc indent {text {prefix " "}} { - set result [list] - foreach line [split $text \n] { - if {[string trim $line] eq ""} { - lappend result "" - } else { - lappend result $prefix[string trimright $line] - } - } - return [join $result \n] - } - #dedent? - proc undent {text} { - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - regexp {^([\t ]*)} $lcp _m lcp - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - - #hacky - proc undentleader {text leader} { - #leader usually whitespace - but doesn't have to be - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - lappend nonblank "${leader}!!" - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - #regexp {^([\t ]*)} $lcp _m lcp - #lcp can be shorter than leader - set lcp [string range $lcp 0 [string length $leader]-1] - - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - #A version of textutil::string::longestCommonPrefixList - proc longestCommonPrefix {items} { - if {[llength $items] <= 1} { - return [lindex $items 0] - } - set items [lsort $items[unset items]] - set min [lindex $items 0] - set max [lindex $items end] - #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) - #(sort order nothing to do with length - e.g min may be longer than max) - if {[string length $min] > [string length $max]} { - set temp $min - set min $max - set max $temp - } - set n [string length $min] - set prefix "" - set i -1 - while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { - append prefix $c - } - return $prefix - } - - #order-preserving - #(same as punk::lib) - proc lunique {list} { - set new {} - foreach item $list { - if {$item ni $new} { - lappend new $item - } - } - return $new - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] -} - -tcl::namespace::eval punk::args::argdocbase { - namespace export * - #use a? to test and create literal ansi here rather than relying on punk::ansi package presence - #e.g - #% a? bold - #- bold │SGR 1│sample│␛[1msample - #- ──────┼─────┼──────┼────────── - #- RESULT│ │sample│␛[1msample - proc B {} {return \x1b\[1m} ;#a+ bold - proc N {} {return \x1b\[22m} ;#a+ normal - proc I {} {return \x1b\[3m} ;#a+ italic - proc NI {} {return \x1b\[23m} ;#a+ noitalic - -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::package { - variable PUNKARGS - lappend PUNKARGS [list { - @dynamic - @id -id "::punk::args::package::standard_about" - @cmd -name "%pkg%::about" -help\ - "About %pkg% - ... - " - -package_about_namespace -type string -optional 0 -help\ - "Namespace containing the package about procedures - Must contain " - -return\ - -type string\ - -default table\ - -choices {string table tableobject}\ - -choicelabels { - string\ - "A basic text layout" - table\ - "layout in table borders - (requires package: textblock)" - tableobject\ - "textblock::class::table object instance" - }\ - -help\ - "Choose the return type of the 'about' information" - topic -optional 1\ - -nocase 1\ - -default {*}\ - -choices {Description License Version Contact *}\ - -choicerestricted 0\ - -choicelabels { - - }\ - -multiple 1\ - -help\ - "Topic to display. Omit or specify as * to see all. - If * is included with explicit topics, * represents - the remaining unmentioned topics." - }] - proc standard_about {args} { - set argd [punk::args::parse $args withid ::punk::args::package::standard_about] - lassign [dict values $argd] leaders OPTS values received - - set pkgns [dict get $OPTS -package_about_namespace] - if {[info commands ${pkgns}::package_name] eq ""} { - error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" - } - set pkgname [${pkgns}::package_name] - - set opt_return [dict get $OPTS -return] - set all_topics [${pkgns}::about_topics] - if {![dict exists $received topic]} { - set topics $all_topics - } else { - # * represents all remaining topics not explicitly mentioned. - set val_topics [dict get $values topic] ;#if -multiple is true, this is a list - set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] - set topics [list] - foreach t $val_topics { - if {$t eq "*"} { - foreach a $all_topics { - if {$a ni $explicit_topics} { - lappend topics $a - } - } - } else { - lappend topics $t - } - } - } - if {$opt_return ne "string"} { - package require textblock ;#table support - set is_table 1 - set title [string cat {[} $pkgname {]} ] - set t [textblock::class::table new -title $title] - $t configure -frametype double -minwidth [expr {[string length $title]+2}] - - } else { - set topiclens [lmap t $topics {string length $t}] - set widest_topic [tcl::mathfunc::max {*}$topiclens] - set is_table 0 - set about "$pkgname\n" - append about [string repeat - $widest_topic] \n - } - foreach topic $topics { - if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { - set topic_contents [::${pkgns}::get_topic_$topic] - } else { - set topic_contents "" - } - if {!$is_table} { - set content_lines [split $topic_contents \n] - append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n - foreach ln [lrange $content_lines 1 end] { - append about [format %-${widest_topic}s ""] " " $ln \n - } - } else { - $t add_row [list $topic $topic_contents] - } - } - - if {!$is_table} { - return $about - } else { - if {$opt_return eq "tableobject"} { - return $t - } - set result [$t print] - $t destroy - return $result - } - } - -} - -#usually we would directly call arg definitions near the defining proc, -# so that the proc could directly use the definition in its parsing. -# -#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. -#arguably it may be more processor-cache-efficient to do together like this anyway. - -#can't do this here? - as there is circular dependency with punk::lib -#tcl::namespace::eval punk::args { -# foreach deflist $PUNKARGS { -# punk::args::define {*}$deflist -# } -# set PUNKARGS "" -#} - -lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -tcl::namespace::eval punk::args::system { - #*** !doctools - #[subsection {Namespace punk::args::system}] - #[para] Internal functions that are not part of the API - - #dict get value with default wrapper for tcl 8.6 - if {[info commands ::tcl::dict::getdef] eq ""} { - proc Dict_getdef {dictValue args} { - set keys [lrange $args 0 end-1] - if {[tcl::dict::exists $dictValue {*}$keys]} { - return [tcl::dict::get $dictValue {*}$keys] - } else { - return [lindex $args end] - } - } - } else { - #we pay a minor perf penalty for the wrap - interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef - } - - #name to reflect maintenance - home is punk::lib::ldiff - proc punklib_ldiff {fromlist removeitems} { - if {[llength $removeitems] == 0} {return $fromlist} - set result {} - foreach item $fromlist { - if {$item ni $removeitems} { - lappend result $item - } - } - return $result - } - -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::args [tcl::namespace::eval punk::args { - tcl::namespace::path {::punk::args::lib ::punk::args::system} - variable pkg punk::args - variable version - set version 0.1.9 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.tm index 7b6ee228..d8c43c45 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.tm @@ -3608,7 +3608,12 @@ tcl::namespace::eval punk::args { #A_PREFIX can resolve to empty string if colour off #we then want to display underline instead set A_PREFIX [a+ underline] - set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + #set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space (zwsp) + set A_PREFIXEND [a+ nounderline] + #review - zwsp problematic on older terminals that print it visibly + #- especially if they also lie about cursor position after it's emitted. + #so although the zwsp fixes the issue where the underline extends to rhs padding if all text was underlined, + #It's probably best fixed in the padding functionality. } else { set A_PREFIXEND $RST } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm index 4d4518d3..b8b56d23 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm @@ -211,9 +211,9 @@ namespace eval punk::console { set result [dict create] if {"output" in $channels} { #note setting stdout makes stderr have the same settings - ie there is really only one output to configure - set h_out [twapi::get_console_handle stdout] + set h_out [twapi::get_console_handle stdout] set oldmode [twapi::GetConsoleMode $h_out] - set newmode [expr {$oldmode | 4}] + set newmode [expr {$oldmode | 4}] twapi::SetConsoleMode $h_out $newmode dict set result output [list from $oldmode to $newmode] } @@ -255,7 +255,7 @@ namespace eval punk::console { #as above - configuring stdout does stderr too set h_out [twapi::get_console_handle stdout] set oldmode [twapi::GetConsoleMode $h_out] - set newmode [expr {$oldmode & ~4}] + set newmode [expr {$oldmode & ~4}] twapi::SetConsoleMode $h_out $newmode dict set result output [list from $oldmode to $newmode] } @@ -412,7 +412,7 @@ namespace eval punk::console { } if {$wrote} { tsv::set console is_raw 1 - after 100 + #after 100 close $pipe } else { puts stderr "write to $ps_pipename failed trynum: $trynum\n$errMsg" diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.0.tm deleted file mode 100644 index fea9534f..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.0.tm +++ /dev/null @@ -1,1472 +0,0 @@ -# -*- 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: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.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 punk::lib 0.1.0 -# Meta platform tcl -# Meta license BSD -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::lib 0 0.1.0] -#[copyright "2024"] -#[titledesc {punk general utility functions}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk library}] [comment {-- Description at end of page heading --}] -#[require punk::lib] -#[keywords module utility lib] -#[description] -#[para]This is a set of utility functions that are commonly used across punk modules or are just considered to be general-purpose functions. -#[para]The base set includes string and math functions but has no specific theme - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of punk::lib -#[subsection Concepts] -#[para]The punk::lib modules should have no strong dependencies other than Tcl -#[para]Dependendencies that only affect display or additional functionality may be included - but should fail gracefully if not present, and only when a function is called that uses one of these soft dependencies. -#[para]This requirement for no strong dependencies, means that many utility functions that might otherwise seem worthy of inclusion here are not present. - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::lib -#[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 -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval punk::lib::class { - #*** !doctools - #[subsection {Namespace punk::lib::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 punk::lib { - namespace export * - #variable xyz - - #*** !doctools - #[subsection {Namespace punk::lib}] - #[para] Core API functions for punk::lib - #[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" - #} - - proc K {x y} {return $x} - #*** !doctools - #[call [fun K] [arg x] [arg y]] - #[para]The K-combinator function - returns the first argument, x and discards y - #[para]see [uri https://wiki.tcl-lang.org/page/K] - #[para]It is used in cases where command-substitution at the calling-point performs some desired effect. - - proc hex2dec {args} { - #*** !doctools - #[call [fun hex2dec] [opt {option value...}] [arg list_largeHex]] - #[para]Convert a list of (possibly large) unprefixed hex strings to their decimal values - #[para]hex2dec accepts and ignores internal underscores in the same manner as Tcl 8.7+ numbers e.g hex2dec FF_FF returns 65535 - #[para]Leading and trailing underscores are ignored as a matter of implementation convenience - but this shouldn't be relied upon. - #[para]Leading or trailing whitespace in each list member is allowed e.g hex2dec " F" returns 15 - #[para]Internal whitespace e.g "F F" is not permitted - but a completely empty element "" is allowed and will return 0 - - set list_largeHex [lindex $args end] - set argopts [lrange $args 0 end-1] - if {[llength $argopts]%2 !=0} { - error "[namespace current]::hex2dec arguments prior to list_largeHex must be option/value pairs - received '$argopts'" - } - set defaults [dict create\ - -validate 1\ - -empty_as_hex "INVALID set -empty_as_hex to a hex string e.g FF if empty values should be replaced"\ - ] - set known_opts [dict keys $defaults] - set fullopts [dict create] - dict for {k v} $argopts { - dict set fullopts [tcl::prefix match -message "options for hex2dec. Unexpected option" $known_opts $k] $v - } - set opts [dict merge $defaults $fullopts] - # -- --- --- --- - set opt_validate [dict get $opts -validate] - set opt_empty [dict get $opts -empty_as_hex] - # -- --- --- --- - - set list_largeHex [lmap h $list_largeHex[unset list_largeHex] {string map [list _ ""] [string trim $h]}] - if {$opt_validate} { - #Note appended F so that we accept list of empty strings as per the documentation - if {![string is xdigit -strict [join $list_largeHex ""]F ]} { - error "[namespace current]::hex2dec error: non-hex digits encountered after stripping underscores and leading/trailing whitespace for each element\n $list_largeHex" - } - } - if {![string is xdigit -strict [string map [list _ ""] $opt_empty]]} { - #mapping empty string to a value destroys any advantage of -scanonly - #todo - document that -scanonly has 2 restrictions - each element must be valid hex and less than 7 chars long - #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {0} : {[set v]}}] - if {[lsearch $list_largeHex ""] >=0} { - error "[namespace current]::hex2dec error: empty values in list cannot be mapped to non-hex $opt_empty" - } - } else { - set opt_empty [string trim [string map [list _ ""] $opt_empty]] - if {[set first_empty [lsearch $list_largeHex ""]] >= 0} { - #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {$opt_empty} : {$v}}] - set nonempty_head [lrange $list_largeHex 0 $first_empty-1] - set list_largeHex [concat $nonempty_head [lmap v [lrange $list_largeHex $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] - } - } - return [scan $list_largeHex [string repeat %llx [llength $list_largeHex]]] - } - - proc dec2hex {args} { - #*** !doctools - #[call [fun dex2hex] [opt {option value...}] [arg list_decimals]] - #[para]Convert a list of decimal integers to a list of hex values - #[para] -width can be used to make each hex value at least int characters wide, with leading zeroes. - #[para] -case upper|lower determines the case of the hex letters in the output - set list_decimals [lindex $args end] - set argopts [lrange $args 0 end-1] - if {[llength $argopts]%2 !=0} { - error "[namespace current]::dec2hex arguments prior to list_decimals must be option/value pairs - received '$argopts'" - } - set defaults [dict create\ - -width 1\ - -case upper\ - -empty_as_decimal "INVALID set -empty_as_decimal to a number if empty values should be replaced"\ - ] - set known_opts [dict keys $defaults] - set fullopts [dict create] - dict for {k v} $argopts { - dict set fullopts [tcl::prefix match -message "options for [namespace current]::dec2hex. Unexpected option" $known_opts $k] $v - } - set opts [dict merge $defaults $fullopts] - # -- --- --- --- - set opt_width [dict get $opts -width] - set opt_case [dict get $opts -case] - set opt_empty [dict get $opts -empty_as_decimal] - # -- --- --- --- - - - set resultlist [list] - if {[string tolower $opt_case] eq "upper"} { - set spec X - } elseif {[string tolower $opt_case] eq "lower"} { - set spec x - } else { - error "[namespace current]::dec2hex unknown value '$opt_case' for -case expected upper|lower" - } - set fmt "%${opt_width}.${opt_width}ll${spec}" - - set list_decimals [lmap d $list_decimals[unset list_decimals] {string map [list _ ""] [string trim $d]}] - if {![string is digit -strict [string map [list _ ""] $opt_empty]]} { - if {[lsearch $list_decimals ""] >=0} { - error "[namespace current]::dec2hex error: empty values in list cannot be mapped to non-decimal $opt_empty" - } - } else { - set opt_empty [string map [list _ ""] $opt_empty] - if {[set first_empty [lsearch $list_decimals ""]] >= 0} { - set nonempty_head [lrange $list_decimals 0 $first_empty-1] - set list_decimals [concat $nonempty_head [lmap v [lrange $list_decimals $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] - } - } - return [format [lrepeat [llength $list_decimals] $fmt] {*}$list_decimals] - } - - proc log2 x "expr {log(\$x)/[expr log(2)]}" - #*** !doctools - #[call [fun log2] [arg x]] - #[para]log base2 of x - #[para]This uses a 'live' proc body - the divisor for the change of base is computed once at definition time - #[para](courtesy of RS [uri https://wiki.tcl-lang.org/page/Additional+math+functions]) - - proc logbase {b x} { - #*** !doctools - #[call [fun logbase] [arg b] [arg x]] - #[para]log base b of x - #[para]This function uses expr's natural log and the change of base division. - #[para]This means for example that we can get results like: logbase 10 1000 = 2.9999999999999996 - #[para]Use expr's log10() function or tcl::mathfunc::log10 for base 10 - expr {log($x)/log($b)} - } - proc factors {x} { - #*** !doctools - #[call [fun factors] [arg x]] - #[para]Return a sorted list of the positive factors of x where x > 0 - #[para]For x = 0 we return only 0 and 1 as technically any number divides zero and there are an infinite number of factors. (including zero itself in this context)* - #[para]This is a simple brute-force implementation that iterates all numbers below the square root of x to check the factors - #[para]Because the implementation is so simple - the performance is very reasonable for numbers below at least a few 10's of millions - #[para]See tcllib math::numtheory::factors for a more complex implementation - which seems to be slower for 'small' numbers - #[para]Comparisons were done with some numbers below 17 digits long - #[para]For seriously big numbers - this simple algorithm would no doubt be outperformed by more complex algorithms. - #[para]The numtheory library stores some data about primes etc with each call - so may become faster when being used on more numbers - #but has the disadvantage of being slower for 'small' numbers and using more memory. - #[para]If the largest factor below x is needed - the greatestOddFactorBelow and GreatestFactorBelow functions are a faster way to get there than computing the whole list, even for small values of x - #[para]* Taking x=0; Notion of x being divisible by integer y being: There exists an integer p such that x = py - #[para] In other mathematical contexts zero may be considered not to divide anything. - set factors [list 1] - set j 2 - set max [expr {sqrt($x)}] - while {$j <= $max} { - if {($x % $j) == 0} { - lappend factors $j [expr {$x / $j}] - } - incr j - } - lappend factors $x - return [lsort -unique -integer $factors] - } - proc oddFactors {x} { - #*** !doctools - #[call [fun oddFactors] [arg x]] - #[para]Return a list of odd integer factors of x, sorted in ascending order - set j 2 - set max [expr {sqrt($x)}] - set factors [list 1] - while {$j <= $max} { - if {$x % $j == 0} { - set other [expr {$x / $j}] - if {$other % 2 != 0} { - if {$other ni $factors} { - lappend factors $other - } - } - if {$j % 2 != 0} { - if {$j ni $factors} { - lappend factors $j - } - } - } - incr j - } - return [lsort -integer -increasing $factors] - } - proc greatestFactorBelow {x} { - #*** !doctools - #[call [fun greatestFactorBelow] [arg x]] - #[para]Return the largest factor of x excluding itself - #[para]factor functions can be useful for console layout calculations - #[para]See Tcllib math::numtheory for more extensive implementations - if {$x % 2 == 0 || $x == 0} { - return [expr {$x / 2}] - } - set j 3 - set max [expr {sqrt($x)}] - while {$j <= $max} { - if {$x % $j == 0} { - return [expr {$x / $j}] - } - incr j 2 - } - return 1 - } - proc greatestOddFactorBelow {x} { - #*** !doctools - #[call [fun greatestOddFactorBelow] [arg x]] - #[para]Return the largest odd integer factor of x excluding x itself - if {$x %2 == 0} { - return [greatestOddFactor $x] - } - set j 3 - #dumb brute force - time taken to compute is wildly variable on big numbers - #todo - use a (memoized?) generator of primes to reduce the search space - #tcllib math::numtheory has suitable functions - but do we want that dependency here? Testing shows brute-force often faster for small numbers. - set god 1 - set max [expr {sqrt($x)}] - while { $j <= $max} { - if {$x % $j == 0} { - set other [expr {$x / $j}] - if {$other % 2 == 0} { - set god $j - } else { - set god [expr {$x / $j}] - #lowest j - so other side must be highest - break - } - } - incr j 2 - } - return $god - } - proc greatestOddFactor {x} { - #*** !doctools - #[call [fun greatestOddFactor] [arg x]] - #[para]Return the largest odd integer factor of x - #[para]For an odd value of x - this will always return x - if {$x % 2 != 0 || $x == 0} { - return $x - } - set r [expr {$x / 2}] - while {$r % 2 == 0} { - set r [expr {$r / 2}] - } - return $r - } - proc gcd {n m} { - #*** !doctools - #[call [fun gcd] [arg n] [arg m]] - #[para]Return the greatest common divisor of m and n - #[para]Straight from Lars Hellström's math::numtheory library in Tcllib - #[para]Graphical use: - #[para]An a by b rectangle can be covered with square tiles of side-length c, - #[para]only if c is a common divisor of a and b - - # - # Apply Euclid's good old algorithm - # - if { $n > $m } { - set t $n - set n $m - set m $t - } - - while { $n > 0 } { - set r [expr {$m % $n}] - set m $n - set n $r - } - - return $m - } - proc lcm {n m} { - #*** !doctools - #[call [fun gcd] [arg n] [arg m]] - #[para]Return the lowest common multiple of m and n - #[para]Straight from Lars Hellström's math::numtheory library in Tcllib - #[para] - set gcd [gcd $n $m] - return [expr {$n*$m/$gcd}] - } - proc commonDivisors {x y} { - #*** !doctools - #[call [fun commonDivisors] [arg x] [arg y]] - #[para]Return a list of all the common factors of x and y - #[para](equivalent to factors of their gcd) - return [factors [gcd $x $y]] - } - - #experimental only - there are better/faster ways - proc sieve n { - set primes [list] - if {$n < 2} {return $primes} - set nums [dict create] - for {set i 2} {$i <= $n} {incr i} { - dict set nums $i "" - } - set next 2 - set limit [expr {sqrt($n)}] - while {$next <= $limit} { - for {set i $next} {$i <= $n} {incr i $next} {dict unset nums $i} - lappend primes $next - dict for {next -} $nums break - } - return [concat $primes [dict keys $nums]] - } - proc sieve2 n { - set primes [list] - if {$n < 2} {return $primes} - set nums [dict create] - for {set i 2} {$i <= $n} {incr i} { - dict set nums $i "" - } - set next 2 - set limit [expr {sqrt($n)}] - while {$next <= $limit} { - for {set i $next} {$i <= $n} {incr i $next} {dict unset nums $i} - lappend primes $next - #dict for {next -} $nums break - set next [lindex $nums 0] - } - return [concat $primes [dict keys $nums]] - } - - proc hasglobs {str} { - #*** !doctools - #[call [fun hasglobs] [arg str]] - #[para]Return a boolean indicating whether str contains any of the glob characters: * ? [lb] [rb] - #[para]hasglobs uses append to preserve Tcls internal representation for str - so it should help avoid shimmering in the few cases where this may matter. - regexp {[*?\[\]]} [append obj2 $str {}] ;# int-rep preserving - } - - proc trimzero {number} { - #*** !doctools - #[call [fun trimzero] [arg number]] - #[para]Return number with left-hand-side zeros trimmed off - unless all zero - #[para]If number is all zero - a single 0 is returned - set trimmed [string trimleft $number 0] - if {[string length $trimmed] == 0} { - set trimmed 0 - } - return $trimmed - } - proc substring_count {str substring} { - #*** !doctools - #[call [fun substring_count] [arg str] [arg substring]] - #[para]Search str and return number of occurrences of substring - - #faster than lsearch on split for str of a few K - if {$substring eq ""} {return 0} - set occurrences [expr {[string length $str]-[string length [string map [list $substring {}] $str]]}] - return [expr {$occurrences / [string length $substring]}] - } - - proc dict_merge_ordered {defaults main} { - #*** !doctools - #[call [fun dict_merge_ordered] [arg defaults] [arg main]] - #[para]The standard dict merge accepts multiple dicts with values from dicts to the right (2nd argument) taking precedence. - #[para]When merging with a dict of default values - this means that any default key/vals that weren't in the main dict appear in the output before the main data. - #[para]This function merges the two dicts whilst maintaining the key order of main followed by defaults. - - #1st merge (inner merge) with wrong values taking precedence - but right key-order - then (outer merge) restore values - return [dict merge [dict merge $main $defaults] $main] - } - - proc askuser {question} { - #*** !doctools - #[call [fun askuser] [arg question]] - #[para]A basic utility to read an answer from stdin - #[para]The prompt is written to the terminal and then it waits for a user to type something - #[para]stdin is temporarily configured to blocking and then put back in its original state in case it wasn't already so. - #[para]If the terminal is using punk::console and is in raw mode - the terminal will temporarily be put in line mode. - #[para](Generic terminal raw vs linemode detection not yet present) - #[para]The user must hit enter to submit the response - #[para]The return value is the string if any that was typed prior to hitting enter. - #[para]The question argument can be manually colourised using the various punk::ansi funcitons - #[example_begin] - # set answer [lb]punk::lib::askuser "[lb]a+ green bold[rb]Do you want to proceed? (Y|N)[lb]a[rb]"[rb] - # if {[lb]string match y* [lb]string tolower $answer[rb][rb]} { - # puts "Proceeding" - # } else { - # puts "Cancelled by user" - # } - #[example_end] - puts stdout $question - flush stdout - set stdin_state [fconfigure stdin] - if {[catch { - package require punk::console - set console_raw [set ::punk::console::is_raw] - } err_console]} { - #assume normal line mode - set console_raw 0 - } - try { - fconfigure stdin -blocking 1 - if {$console_raw} { - punk::console::disableRaw - set answer [gets stdin] - punk::console::enableRaw - } else { - set answer [gets stdin] - } - } finally { - fconfigure stdin -blocking [dict get $stdin_state -blocking] - } - 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 - #[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 ? " - } - 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} { - #*** !doctools - #[call [fun lines_as_list] [opt {option value ...}] [arg text]] - #[para]Returns a list of possibly trimmed lines depeding on options - #[para]The concept of lines is raw lines from splitting on newline after crlf is mapped to lf - #[para]- not console lines which may be entirely different due to control characters such as vertical tabs or ANSI movements - - #The underlying function linelist has the validation code which gives nicer 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 text" - if {[llength $args] == 0} { - error "linelist missing textchunk argument usage:$usage" - } - set text [lindex $args end] - set text [string map [list \r\n \n] $text] ;#review - option? - - 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 values - #[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 , -maxvalues , -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 - #[list_end] [comment {--- end definitions namespace punk::lib ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#todo - way to generate 'internal' docs separately? -#*** !doctools -#[section Internal] -namespace eval punk::lib::system { - #*** !doctools - #[subsection {Namespace punk::lib::system}] - #[para] Internal functions that are not part of the API - #[list_begin definitions] - - proc mostFactorsBelow {n} { - ##*** !doctools - #[call [fun mostFactorsBelow] [arg n]] - #[para]Find the number below $n which has the greatest number of factors - #[para]This will get slow quickly as n increases (100K = 1s+ 2024) - set most 0 - set mostcount 0 - for {set i 1} {$i < $n} {incr i} { - set fc [llength [punk::lib::factors $i]] - if {$fc > $mostcount} { - set most $i - set mostcount $fc - } - } - return [list number $most numfactors $mostcount] - } - proc factorCountBelow_punk {n} { - ##*** !doctools - #[call [fun factorCountBelow] [arg n]] - #[para]For numbers 1 to n - keep a tally of the total count of factors - #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result - #[para]and as a rudimentary performance comparison - #[para]gets slow quickly! - set tally 0 - for {set i 1} {$i <= $n} {incr i} { - incr tally [llength [punk::lib::factors $i]] - } - return $tally - } - proc factorCountBelow_numtheory {n} { - ##*** !doctools - #[call [fun factorCountBelow] [arg n]] - #[para]For numbers 1 to n - keep a tally of the total count of factors - #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result - #[para]and as a rudimentary performance comparison - #[para]gets slow quickly! (significantly slower than factorCountBelow_punk) - package require math::numtheory - set tally 0 - for {set i 1} {$i <= $n} {incr i} { - incr tally [llength [math::numtheory::factors $i]] - } - return $tally - } - - proc factors2 {x} { - ##*** !doctools - #[call [fun factors2] [arg x]] - #[para]Return a sorted list of factors of x - #[para]A similar brute-force mechanism to factors - but keeps result ordering as we go. - set smallfactors [list 1] - set j 2 - set max [expr {sqrt($x)}] - while {$j < $max} { - if {($x % $j) == 0} { - lappend smallfactors $j - lappend largefactors [expr {$x / $j}] - } - incr j - } - #handle sqrt outside loop so we don't have to sort/dedup or check list membership in main loop - if {($x % $j) == 0} { - if {$j == ($x / $j)} { - lappend smallfactors $j - } - } - return [concat $smallfactors [lreverse $largefactors] $x] - } - - #important - used by punk::repl - proc incomplete {partial} { - #we can apparently get away without concatenating current innerpartial to previous in list - REVIEW. - if {[info complete $partial]} { - return [list] - } - set clist [split $partial ""] - #puts stderr "-->$clist<--" - set waiting [list ""] - set innerpartials [list ""] - set escaped 0 - foreach c $clist { - if {$c eq "\\"} { - set escaped [expr {!$escaped}] - continue - } ;# set escaped 0 at end - set p [lindex $innerpartials end] - if {$escaped == 0} { - if {$c eq {"}} { - if {![info complete ${p}]} { - lappend waiting {"} - lappend innerpartials "" - } else { - if {[lindex $waiting end] eq {"}} { - #this quote is endquote - set waiting [lrange $waiting 0 end-1] - set innerpartials [lrange $innerpartials 0 end-1] - } else { - if {![info complete ${p}$c]} { - lappend waiting {"} - lappend innerpartials "" - } else { - set p ${p}${c} - lset innerpartials end $p - } - } - } - } elseif {$c eq "\["} { - if {![info complete ${p}$c]} { - lappend waiting "\]" - lappend innerpartials "" - } else { - set p ${p}${c} - lset innerpartials end $p - } - } elseif {$c eq "\{"} { - if {![info complete ${p}$c]} { - lappend waiting "\}" - lappend innerpartials "" - } else { - set p ${p}${c} - lset innerpartials end $p - } - } else { - set waitingfor [lindex $waiting end] - if {$c eq "$waitingfor"} { - set waiting [lrange $waiting 0 end-1] - set innerpartials [lrange $innerpartials 0 end-1] - } else { - set p ${p}${c} - lset innerpartials end $p - } - } - } else { - set p ${p}${c} - lset innerpartials end $p - } - set escaped 0 - } - set incomplete [list] - foreach w $waiting { - if {$w eq {"}} { - lappend incomplete $w - } elseif {$w eq "\]"} { - lappend incomplete "\[" - } elseif {$w eq "\}"} { - lappend incomplete "\{" - } - } - set debug 0 - if {$debug} { - foreach w $waiting p $innerpartials { - puts stderr "->'$w' partial: $p" - } - } - return $incomplete - } - #This only works for very simple cases will get confused with for example: - # {set x "a["""} - proc incomplete_naive {partial} { - if {[info complete $partial]} { - return [list] - } - set clist [split $partial ""] - set waiting [list] - set escaped 0 - foreach c $clist { - if {$c eq "\\"} { - set escaped [expr {!$escaped}] - continue - } - if {!$escaped} { - if {$c eq {"}} { - if {[lindex $waiting end] eq {"}} { - set waiting [lrange $waiting 0 end-1] - } else { - lappend waiting {"} - } - } elseif {$c eq "\["} { - lappend waiting "\]" - } elseif {$c eq "\{"} { - lappend waiting "\}" - } else { - set waitingfor [lindex $waiting end] - if {$c eq "$waitingfor"} { - set waiting [lrange $waiting 0 end-1] - } - } - } - } - set incomplete [list] - foreach w $waiting { - if {$w eq {"}} { - lappend incomplete $w - } elseif {$w eq "\]"} { - lappend incomplete "\[" - } elseif {$w eq "\}"} { - lappend incomplete "\{" - } - } - return $incomplete - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::lib::system ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::lib [namespace eval punk::lib { - variable pkg punk::lib - variable version - set version 0.1.0 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm deleted file mode 100644 index b6c6dd4a..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm +++ /dev/null @@ -1,4238 +0,0 @@ -# -*- 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: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.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 punk::lib 0.1.1 -# Meta platform tcl -# Meta license BSD -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::lib 0 0.1.1] -#[copyright "2024"] -#[titledesc {punk general utility functions}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk library}] [comment {-- Description at end of page heading --}] -#[require punk::lib] -#[keywords module utility lib] -#[description] -#[para]This is a set of utility functions that are commonly used across punk modules or are just considered to be general-purpose functions. -#[para]The base set includes string and math functions but has no specific theme - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of punk::lib -#[subsection Concepts] -#[para]The punk::lib modules should have no strong dependencies other than Tcl -#[para]Dependendencies that only affect display or additional functionality may be included - but should fail gracefully if not present, and only when a function is called that uses one of these soft dependencies. -#[para]This requirement for no strong dependencies, means that many utility functions that might otherwise seem worthy of inclusion here are not present. - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::lib -#[list_begin itemized] - -package require Tcl 8.6- -package require punk::args -#*** !doctools -#[item] [package {Tcl 8.6-}] -#[item] [package {punk::args}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - - -tcl::namespace::eval punk::lib::ensemble { - #wiki.tcl-lang.org/page/ensemble+extend - # extend an ensemble-like routine with the routines in some namespace - proc extend {routine extension} { - if {![string match ::* $routine]} { - set resolved [uplevel 1 [list ::tcl::namespace::which $routine]] - if {$resolved eq {}} { - error [list {no such routine} $routine] - } - set routine $resolved - } - set routinens [tcl::namespace::qualifiers $routine] - if {$routinens eq {::}} { - set routinens {} - } - set routinetail [tcl::namespace::tail $routine] - - if {![string match ::* $extension]} { - set extension [uplevel 1 [ - list [tcl::namespace::which namespace] current]]::$extension - } - - if {![tcl::namespace::exists $extension]} { - error [list {no such namespace} $extension] - } - - set extension [tcl::namespace::eval $extension [ - list [tcl::namespace::which namespace] current]] - - tcl::namespace::eval $extension [ - list [tcl::namespace::which namespace] export *] - - while 1 { - set renamed ${routinens}::${routinetail}_[clock clicks] ;#clock clicks unlikely to collide when not directly consecutive such as: list [clock clicks] [clock clicks] - if {[tcl::namespace::which $renamed] eq {}} break - } - - rename $routine $renamed - - tcl::namespace::eval $extension [ - list namespace ensemble create -command $routine -unknown [ - list apply {{renamed ensemble routine args} { - list $renamed $routine - }} $renamed - ] - ] - - return $routine - } -} - -# some (?) tcl bug check procs needed to exist before main punk::lib namespaces are evaluated -tcl::namespace::eval punk::lib::check { - proc has_tclbug_script_var {} { - - set script {set j [list spud] ; list} - append script \n - uplevel #0 $script - set rep1 [tcl::unsupported::representation $::j] - set script "" - set rep2 [tcl::unsupported::representation $::j] - - set nostring1 [string match "*no string" $rep1] - set nostring2 [string match "*no string" $rep2] - - #we assume it should have no string rep in either case - #Review: check Tcl versions for behaviour/consistency - if {!$nostring2} { - return true - } else { - return false - } - } - proc has_tclbug_lsearch_strideallinline {} { - #bug only occurs with single -index value combined with -stride -all -inline -subindices - #https://core.tcl-lang.org/tcl/tktview/5a1aaa201d - if {[catch {lsearch -stride 3 -all -inline -index 1 -subindices {a1 a2 a3} *} result]} { - #we aren't looking for an error result - error most likely indicates tcl too old to support -stride - return 0 - } - return [expr {$result ne "a2"}] - } - - proc has_tclbug_list_quoting_emptyjoin {} { - #https://core.tcl-lang.org/tcl/tktview/e38dce74e2 - set v1 [list {*}[lindex #foo] {*}[]] ;#can return "#foo" instead of "{#foo}" under some beta 9 releases - set v2 [list #foo] ;#normal tcl list quoting for 1st element that looks like a comment -> "{#foo}" - return [expr {![string equal $v1 $v2]}] ;#if they're not equal - we have the bug. - } - - proc has_tclbug_safeinterp_compile {{show 0}} { - #ensemble calls within safe interp not compiled - namespace eval [namespace current]::testcompile { - proc ensembletest {} {string index a 0} - } - - set has_bug 0 - - set bytecode_outer [tcl::unsupported::disassemble proc [namespace current]::testcompile::ensembletest] - if {$show} { - puts outer: - puts $bytecode_outer - } - if {![interp issafe]} { - #test of safe subinterp only needed if we aren't already in a safe interp - if {![catch { - interp create x -safe - } errMsg]} { - x eval {proc ensembletest {} {string index a 0}} - set bytecode_safe [x eval {tcl::unsupported::disassemble proc ::ensembletest}] - if {$show} { - puts safe: - puts $bytecode_safe - } - interp delete x - #mainly we expect the safe interp might contain invokeStk - indicating not byte compiled (or we would see strindex instead) - #It's possible the interp we're running in is also not compiling ensembles. - #we could then get a result of 2 - which still indicates a problem - if {[string last "invokeStk" $bytecode_safe] >= 1} { - incr has_bug - } - } else { - #our failure to create a safe interp here doesn't necessarily mean the Tcl version doesn't have the problem - but we could end up returning zero if somehow safe interp can't be created from unsafe interp? - #unlikely - but we should warn - puts stderr "Unable to create a safe sub-interp to test - result only indicates status of current interpreter" - } - } - - namespace delete [namespace current]::testcompile - - if {[string last "invokeStk" $bytecode_outer] >= 1} { - incr has_bug - } - return $has_bug - } -} - -tcl::namespace::eval punk::lib::compat { - #*** !doctools - #[subsection {Namespace punk::lib::compat}] - #[para] compatibility functions for features that may not be available in earlier Tcl versions - #[para] These are generally 'forward compatibility' functions ie allowing earlier versions to use later features/idioms by using a Tcl-only version of a missing builtin. - #[para] Such Tcl-only versions will inevitably be less performant - perhaps significantly so. - - #*** !doctools - #[list_begin definitions] - - - - - if {"::lremove" ne [info commands ::lremove]} { - #puts stderr "Warning - no built-in lremove" - interp alias {} lremove {} ::punk::lib::compat::lremove - } - proc lremove {list args} { - #*** !doctools - #[call [fun lremove] [arg list] [opt {index ...}]] - #[para] Forwards compatible lremove for versions 8.6 or less to support equivalent 8.7 lremove - - set data [lmap v $list {list data $v}] - foreach doomed_index $args { - if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"} - lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value - } - set keep [lsearch -all -inline -not -exact $data x] - return [lsearch -all -inline -index 1 -subindices $keep *] - } - #not significantly different in performance over test of 100 elements - getting somewhere near 10% for 1k integers - proc lremove2 {list args} { - set data [lmap v $list {list data $v}] - foreach doomed_index $args { - if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"} - lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value - } - set keep [lsearch -all -inline -not -exact $data x] - return [lmap v $keep {lindex $v 1}] - } - #outside of lmap - don't know of any particularly nice ways to flatten to subindex 1 of each element.. - #flattening then lsearch with -stride and * would be nice - but it's not avail in 8.6 - - if {![info exists ::auto_index(readFile)]} { - if {[info commands ::readFile] eq ""} { - proc ::readFile {filename {mode text}} { - #readFile not seen in auto_index or as command: installed by punk::lib - # Parse the arguments - set MODES {binary text} - set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]] - set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode] - - # Read the file - set f [open $filename [dict get {text r binary rb} $mode]] - try { - return [read $f] - } finally { - close $f - } - } - } - } - if {![info exists ::auto_index(writeFile)]} { - if {[info commands ::writeFile] eq ""} { - proc ::writeFile {args} { - #writeFile not seen in auto_index or as command: installed by punk::lib - # Parse the arguments - switch [llength $args] { - 2 { - lassign $args filename data - set mode text - } - 3 { - lassign $args filename mode data - set MODES {binary text} - set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]] - set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode] - } - default { - set COMMAND [lindex [info level 0] 0] - return -code error -errorcode {TCL WRONGARGS} "wrong # args: should be \"$COMMAND filename ?mode? data\"" - } - } - - # Write the File - set f [open $filename [dict get {text w binary wb} $mode]] - try { - puts -nonewline $f $data - } finally { - close $f - } - } - } - } - - if {"::lpop" ne [info commands ::lpop]} { - #puts stderr "Warning - no built-in lpop" - interp alias {} lpop {} ::punk::lib::compat::lpop - } - proc lpop {lvar args} { - #*** !doctools - #[call [fun lpop] [arg listvar] [opt {index}]] - #[para] Forwards compatible lpop for versions 8.6 or less to support equivalent 8.7 lpop - upvar $lvar l - if {![llength $args]} { - set args [list end] - } - set v [lindex $l {*}$args] - set newlist $l - - set path [list] - set subl $l - for {set i 0} {$i < [llength $args]} {incr i} { - set idx [lindex $args $i] - if {![llength [lrange $subl $idx $idx]]} { - error "tcl_lpop index \"$idx\" out of range" - } - lappend path [lindex $args $i] - set subl [lindex $l {*}$path] - } - - set sublist_path [lrange $args 0 end-1] - set tailidx [lindex $args end] - if {![llength $sublist_path]} { - #set newlist [lremove $newlist $tailidx] - set newlist [lreplace $newlist $tailidx $tailidx] - } else { - set sublist [lindex $newlist {*}$sublist_path] - #set sublist [lremove $sublist $tailidx] - set sublist [lreplace $sublist $tailidx $tailidx] - lset newlist {*}$sublist_path $sublist - } - #puts "[set l] -> $newlist" - set l $newlist - return $v - } - - - #slight isolation - varnames don't leak - but calling context vars can be affected - proc lmaptcl2 {varnames list script} { - set result [list] - set values [list] - foreach v $varnames { - lappend values "\$$v" - } - set linkvars [uplevel 1 [list info vars]] - set nscaller [uplevel 1 [list namespace current]] - - set apply_script "" - foreach vname $linkvars { - append apply_script [string map [list %vname% $vname]\ - {upvar 2 %vname% %vname%}\ - ] \n - } - append apply_script $script \n - - #puts "--> $apply_script" - foreach $varnames $list { - lappend result [apply\ - [list\ - $varnames\ - $apply_script\ - $nscaller\ - ] {*}[subst $values]\ - ] - } - return $result - } - - if {"::lmap" ne [info commands ::lmap]} { - #puts stderr "Warning - no built-in lpop" - interp alias {} lmap {} ::punk::lib::compat::lmaptcl - } - #lmap came in Tcl 8.6 - so probably not much need for a tcl forward compatibility version - but here it is anyway - proc lmaptcl {varnames list script} { - set result [list] - set varlist [list] - foreach varname $varnames { - upvar 1 $varname var_$varname ;#ensure no collisions with vars in this proc - lappend varlist var_$varname - } - foreach $varlist $list { - lappend result [uplevel 1 $script] - } - return $result - } - - #tcl8.7/9 compatibility for 8.6 - if {[info commands ::tcl::string::insert] eq ""} { - #https://wiki.tcl-lang.org/page/string+insert - # Pure Tcl implementation of [string insert] command. - proc ::tcl::string::insert {string index insertString} { - # Convert end-relative and TIP 176 indexes to simple integers. - if {[regexp -expanded { - ^(end(?![\t\n\v\f\r ]) # "end" is never followed by whitespace - |[\t\n\v\f\r ]*[+-]?\d+) # m, with optional leading whitespace - (?:([+-]) # op, omitted when index is "end" - ([+-]?\d+))? # n, omitted when index is "end" - [\t\n\v\f\r ]*$ # optional whitespace (unless "end") - } $index _ m op n]} { - # Convert first index to an integer. - switch $m { - end {set index [string length $string]} - default {scan $m %d index} - } - - # Add or subtract second index, if provided. - switch $op { - + {set index [expr {$index + $n}]} - - {set index [expr {$index - $n}]} - } - } elseif {![string is integer -strict $index]} { - # Reject invalid indexes. - return -code error "bad index \"$index\": must be\ - integer?\[+-\]integer? or end?\[+-\]integer?" - } - - # Concatenate the pre-insert, insertion, and post-insert strings. - string cat [string range $string 0 [expr {$index - 1}]] $insertString\ - [string range $string $index end] - } - - # Bind [string insert] to [::tcl::string::insert]. - tcl::namespace::ensemble configure string -map [tcl::dict::replace\ - [tcl::namespace::ensemble configure string -map]\ - insert ::tcl::string::insert] - } - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::lib::compat ---}] -} - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval punk::lib { - variable PUNKARGS - tcl::namespace::export * - variable has_struct_list - set has_struct_list [expr {![catch {package require struct::list}]}] - variable has_struct_set - set has_struct_set [expr {![catch {package require struct::set}]}] - variable has_punk_ansi - set has_punk_ansi [expr {![catch {package require punk::ansi}]}] - set has_twapi 0 - if {"windows" eq $::tcl_platform(platform)} { - set has_twapi [expr {![catch {package require twapi}]}] - } - - #NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed) - proc aliases {{glob *}} { - set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command - set ns_mapped [string map {:: \uFFFF} $ns] - #puts stderr "aliases ns: $ns_mapped" - set segments [split $ns_mapped \uFFFF] ;#include empty string before leading :: - if {![string length [lindex $segments end]]} { - #special case for :: only include leading segment rather thatn {} {} - set segments [lrange $segments 0 end-1] - } - set segcount [llength $segments] ;#only match number of segments matching current ns - - - set all_aliases [interp aliases {}] - set matched [list] - foreach a $all_aliases { - #normalize with leading :: - if {![string match ::* $a]} { - set abs ::$a - } else { - set abs $a - } - - set asegs [split [string map {:: \uFFFF} $abs] \uFFFF] - set acount [llength $asegs] - #puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments" - if {($acount - 1) == $segcount} { - if {[lrange $asegs 0 end-1] eq $segments} { - if {[string match $glob [lindex $asegs end]]} { - #report this alias in the current namespace - even though there may be no matching command - lappend matched $a ;#add raw alias token which may or may not have leading :: - } - } - } - } - #set matched_abs [lsearch -all -inline $all_aliases $glob] - - return $matched - } - - proc alias {{aliasorglob ""} args} { - set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command - if {[llength $args]} { - if {$aliasorglob in [interp aliases ""]} { - set existing [interp alias "" $aliasorglob] - puts stderr "Overwriting existing alias $aliasorglob -> $existing with $aliasorglob -> $args (in current session only)" - } - if {([llength $args] ==1) && [string trim [lindex $args 0]] eq ""} { - #use empty string/whitespace as intention to delete alias - return [interp alias "" $aliasorglob ""] - } - return [interp alias "" $aliasorglob "" {*}$args] - } else { - if {![string length $aliasorglob]} { - set aliaslist [punk::lib::aliases] - puts -nonewline stderr $aliaslist - return - } - #we need to first check for exact match of alias that happens to have glob chars i.e the supplied aliasorglob looks like a glob but is actually directly an alias - set target [interp alias "" $aliasorglob] - if {[llength $target]} { - return $target - } - - if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} { - set aliaslist [punk::lib::aliases $aliasorglob] - puts -nonewline stderr $aliaslist - return - } - return [list] - } - } - - - # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == - # Maintenance - This is the primary source for tm_version... functions - # - certain packages script require these but without package dependency - # - 1 punk boot script - # - 2 packagetrace module - # - These should be updated to sync with this - # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == - proc tm_version_isvalid {versionpart} { - #Needs to be suitable for use with Tcl's 'package vcompare' - if {![catch [list package vcompare $versionpart $versionpart]]} { - return 1 - } else { - return 0 - } - } - proc tm_version_major {version} { - if {![tm_version_isvalid $version]} { - error "Invalid version '$version' is not a proper Tcl module version number" - } - set firstpart [lindex [split $version .] 0] - #check for a/b in first segment - if {[string is integer -strict $firstpart]} { - return $firstpart - } - if {[string first a $firstpart] > 0} { - return [lindex [split $firstpart a] 0] - } - if {[string first b $firstpart] > 0} { - return [lindex [split $firstpart b] 0] - } - error "tm_version_major unable to determine major version from version number '$version'" - } - proc tm_version_canonical {ver} { - #accepts a single valid version only - not a bounded or unbounded spec - if {![tm_version_isvalid $ver]} { - error "tm_version_canonical version '$ver' is not valid for a package version" - } - set parts [split $ver .] - set newparts [list] - foreach o $parts { - set trimmed [string trimleft $o 0] - set firstnonzero [string index $trimmed 0] - switch -exact -- $firstnonzero { - "" { - lappend newparts 0 - } - a - b { - #e.g 000bnnnn -> bnnnnn - set tailtrimmed [string trimleft [string range $trimmed 1 end] 0] - if {$tailtrimmed eq ""} { - set tailtrimmed 0 - } - lappend newparts 0$firstnonzero$tailtrimmed - } - default { - #digit - if {[string is integer -strict $trimmed]} { - #e.g 0100 -> 100 - lappend newparts $trimmed - } else { - #e.g 0100b003 -> 100b003 (still need to process tail) - if {[set apos [string first a $trimmed]] > 0} { - set lhs [string range $trimmed 0 $apos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch - set rhs [string range $trimmed $apos+1 end] ;#assert rhs non-empty and only digits - set rhs [string trimleft $rhs 0] - if {$rhs eq ""} { - set rhs 0 - } - lappend newparts ${lhs}a${rhs} - } elseif {[set bpos [string first b $trimmed]] > 0} { - set lhs [string range $trimmed 0 $bpos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch - set rhs [string range $trimmed $bpos+1 end] ;#assert rhs non-empty and only digits - set rhs [string trimleft $rhs 0] - if {$rhs eq ""} { - set rhs 0 - } - lappend newparts ${lhs}b${rhs} - } else { - #assert - shouldn't get here trimmed val should have been empty, an int or contained an a or b - error "tm_version_canonical error - trimfail - unexpected" - } - } - } - } - } - return [join $newparts .] - } - proc tm_version_required_canonical {versionspec} { - #also trim leading zero from any dottedpart? - #Tcl *allows* leading zeros in any of the dotted parts - but they are not significant. - #e.g 1.01 is equivalent to 1.1 and 01.001 - #also 1b3 == 1b0003 - - if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version - set errmsg "tm_version_required_canonical - invalid version specification" - if {[string first - $versionspec] < 0} { - #no dash - #looks like a minbounded version (ie a single version with no dash) convert to min-max form - set from $versionspec - if {![tm_version_isvalid $from]} { - error "$errmsg '$versionpec'" - } - if {![catch {tm_version_major $from} majorv]} { - set from [tm_version_canonical $from] - return "${from}-[expr {$majorv +1}]" - } else { - error "$errmsg '$versionspec'" - } - } else { - # min- or min-max - #validation and canonicalisation (strip leading zeroes from each segment, including either side of a or b) - set parts [split $versionspec -] ;#we expect only 2 parts - lassign $parts from to - if {![tm_version_isvalid $from]} { - error "$errmsg '$versionspec'" - } - set from [tm_version_canonical $from] - if {[llength $parts] == 2} { - if {$to ne ""} { - if {![tm_version_isvalid $to]} { - error "$errmsg '$versionspec'" - } - set to [tm_version_canonical $to] - return $from-$to - } else { - return $from- - } - } else { - error "$errmsg '$versionspec'" - } - error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point" - } - } - # end tm_version... functions - # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == - - - - # -- --- - #https://stackoverflow.com/questions/17631269/whats-the-best-way-to-join-two-lists - #DKF's 2013 recommendation of using list {*}$first {*}$second seems not to apply in 2024 - #8.6,8.7,9.0 - 'lappend first {*}$second' is many times faster - especially as list grows - # Review and retest as new versions come out. - # -- --- - proc list_multi_append1 {lvar1 lvar2} { - #clear winner in 2024 - upvar $lvar1 l1 $lvar2 l2 - lappend l1 {*}$l2 - return $l1 - } - proc list_multi_append2 {lvar1 lvar2} { - upvar $lvar1 l1 $lvar2 l2 - set l1 [list {*}$l1 {*}$l2] - } - proc list_multi_append3 {lvar1 lvar2} { - upvar $lvar1 l1 $lvar2 l2 - set l1 [lindex [list [list {*}$l1 {*}$l2] [unset l1]] 0] - } - #testing e.g - #set l1_reset {a b c} - #set l2 {a b c d e f g} - #set l1 $l1_reset - #time {list_multi_append1 l1 l2} 1000 - #set l1 $l1_reset - #time {list_multi_append2 l1 l2} 1000 - # -- --- - - - proc lswap {lvar a z} { - upvar $lvar l - if {[lindex_resolve_basic $l $a] < 0 || [lindex_resolve_basic $l $z] < 0} { - #lindex_resolve_basic returns only -1 if out of range - #if we didn't do this check - we could raise an error on second lset below - leaving list corrupted because only one lset occurred - #(e.g using: lswap mylist end-2 end on a two element list) - - #on the unhapy path we can take time to check the nature of the out-of-boundness to give a nicer report - #use full 'lindex_resolve' which can report which side via -3 and -2 special results being lower and upper bound breaches respectively (-1 never returned) - set a_index [lindex_resolve $l $a] - set a_msg "" - switch -- $a_index { - -2 { - set a_msg "1st supplied index $a is above the upper bound for the list ([llength $l])" - } - -3 { - set a_msg "1st supplied index $a is below the lower bound for the list (0)" - } - } - set z_index [lindex_resolve $l $z] - set z_msg "" - switch -- $z_index { - -2 { - set z_msg "2nd supplied index $z is above the upper bound for the list ([llength $l])" - } - -3 { - set z_msg "2nd supplied index $z is below the lower bound for the list (0)" - } - } - set errmsg "lswap cannot swap indices $a and $z" - if {$a_msg ne ""} { - append errmsg \n $a_msg - } - if {$z_msg ne ""} { - append errmsg \n $z_msg - } - error $errmsg - } - set item2 [lindex $l $z] - lset l $z [lindex $l $a] - lset l $a $item2 - return $l - } - #proc lswap2 {lvar a z} { - # upvar $lvar l - # #if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower - # set l [concat [lrange $l 0 $a-1] [lindex $l $z] [lrange $l $a+1 $z-1] [lindex $l $a] [lrange $l $z+1 end]] - #} - - proc lswap2 {lvar a z} { - upvar $lvar l - #if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower - set l [list {*}[lrange $l 0 $a-1] [lindex $l $z] {*}[lrange $l $a+1 $z-1] [lindex $l $a] {*}[lrange $l $z+1 end]] - } - - #an experimental test of swapping vars without intermediate variables - #It's an interesting idea - but probably of little to no practical use - # - the swap_intvars3 version using intermediate var is faster in Tcl - # - This is probably unsurprising - as it's simpler code. - # Even if we tried this technique in c - the compiler would probably do a better job with the intermediate variable than with the math tricks. - #proc swap_intvars {swapv1 swapv2} { - # upvar $swapv1 _x $swapv2 _y - # set _x [expr {[expr {$_x + $_y}] - [set _y $_x]}] - #} - #proc swap_intvars2 {swapv1 swapv2} { - # upvar $swapv1 _x $swapv2 _y - # set _x [expr {$_x ^ $_y}] - # set _y [expr {$_x ^ $_y}] - # set _x [expr {$_x ^ $_y}] - #} - #proc swap_intvars3 {swapv1 swapv2} { - # #using intermediate variable - # upvar $swapv1 _x $swapv2 _y - # set z $_x - # set _x $_y - # set _y $z - #} - - #*** !doctools - #[subsection {Namespace punk::lib}] - #[para] Core API functions for punk::lib - #[list_begin definitions] - - if {[info commands lseq] ne ""} { - #tcl 8.7+ lseq significantly faster, especially for larger ranges - #The internal rep can be an 'arithseries' with no string representation - #support minimal set from to - proc range {from to} { - lseq $from $to - } - } else { - #lseq accepts basic expressions e.g 4-2 for both arguments - #e.g we can do lseq 0 [llength $list]-1 - #if range is to be consistent with the lseq version above - it should support that, even though we don't support most lseq functionality in either wrapper. - proc range {from to} { - set to [offset_expr $to] - set from [offset_expr $from] - if {$to > $from} { - set count [expr {($to -$from) + 1}] - if {$from == 0} { - return [lsearch -all [lrepeat $count 0] *] - } else { - incr from -1 - return [lmap v [lrepeat $count 0] {incr from}] - } - #slower methods. - #2) - #set i -1 - #set L [lrepeat $count 0] - #lmap v $L {lset L [incr i] [incr from];lindex {}} - #return $L - #3) - #set L {} - #for {set i 0} {$i < $count} {incr i} { - # lappend L [incr from] - #} - #return $L - } elseif {$from > $to} { - set count [expr {$from - $to} + 1] - #1) - if {$to == 0} { - return [lreverse [lsearch -all [lrepeat $count 0] *]] - } else { - incr from - return [lmap v [lrepeat $count 0] {incr from -1}] - } - - #2) - #set i -1 - #set L [lrepeat $count 0] - #lmap v $L {lset L [incr i] [incr from -1];lindex {}} - #return $L - #3) - #set L {} - #for {set i 0} {$i < $count} {incr i} { - # lappend L [incr from -1] - #} - #return $L - } else { - return [list $from] - } - } - } - - proc lzip {args} { - switch -- [llength $args] { - 0 {return {}} - 1 {return [lindex $args 0]} - 2 {return [lzip2lists {*}$args]} - 3 {return [lzip3lists {*}$args]} - 4 {return [lzip4lists {*}$args]} - 5 {return [lzip5lists {*}$args]} - 6 {return [lzip6lists {*}$args]} - 7 {return [lzip7lists {*}$args]} - 8 {return [lzip8lists {*}$args]} - 9 {return [lzip9lists {*}$args]} - 10 {return [lzip10lists {*}$args]} - 11 - 12 - 13 - 14 - 15 - 16 - 17 - 18 - 19 - 20 - 21 - 22 - 23 - 24 - 25 - 26 - 27 - 28 - 29 - 30 - 31 - 32 { - set n [llength $args] - if {[info commands ::punk::lib::lzip${n}lists] eq ""} { - puts "calling ::punk::lib::Build_lzipn $n" - ::punk::lib::Build_lzipn $n - } - return [lzip${n}lists {*}$args] - } - default { - if {[llength $args] < 4000} { - set n [llength $args] - if {[info commands ::punk::lib::lzip${n}lists] eq ""} { - puts "calling ::punk::lib::Build_lzipn $n" - ::punk::lib::Build_lzipn $n - } - return [lzip${n}lists {*}$args] - } else { - return [lzipn {*}$args] - } - } - } - } - - proc Build_lzipn {n} { - set arglist [list] - #use punk::lib::range which defers to lseq if available - set vars [lmap i [punk::lib::range 0 $n] {string cat v$i}] ;#v0 v1 v2.. (v0 ignored) - set body "\nlmap " - for {set i 1} {$i <= $n} {incr i} { - lappend arglist l$i - append body "[lindex $vars $i] \$l$i " - } - append body "\{list " - for {set i 1} {$i <= $n} {incr i} { - append body "\$[lindex $vars $i] " - } - append body "\}" \n - puts "proc punk::lib::lzip${n}lists {$arglist} \{" - puts "$body" - puts "\}" - proc ::punk::lib::lzip${n}lists $arglist $body - } - - #fastest is to know the number of lists to be zipped - proc lzip2lists {l1 l2} { - lmap a $l1 b $l2 {list $a $b} - } - proc lzip3lists {l1 l2 l3} { - lmap a $l1 b $l2 c $l3 {list $a $b $c} - } - proc lzip4lists {l1 l2 l3 l4} { - lmap a $l1 b $l2 c $l3 d $l4 {list $a $b $c $d} - } - proc lzip5lists {l1 l2 l3 l4 l5} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 {list $a $b $c $d $e} - } - proc lzip6lists {l1 l2 l3 l4 l5 l6} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 {list $a $b $c $d $e $f} - } - proc lzip7lists {l1 l2 l3 l4 l5 l6 l7} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 {list $a $b $c $d $e $f $g} - } - proc lzip8lists {l1 l2 l3 l4 l5 l6 l7 l8} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 {list $a $b $c $d $e $f $g $h} - } - proc lzip9lists {l1 l2 l3 l4 l5 l6 l7 l8 l9} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 {list $a $b $c $d $e $f $g $h $i} - } - proc lzip10lists {l1 l2 l3 l4 l5 l6 l7 l8 l9 l10} { - lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 j $l10 {list $a $b $c $d $e $f $g $h $i $j} - } - - #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly - # review - - proc lzipn_alt args { - #stackoverflow - courtesy glenn jackman (modified) - foreach l $args { - lappend vars [incr n] - lappend lmap_args $n $l - } - lmap {*}$lmap_args {lmap v $vars {set $v}} - } - - #2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?) - proc lzipn_tcl8 {args} { - #wiki - courtesy JAL - set list_l $args - set zip_l [] - while {1} { - set cur [lmap a_l $list_l { lindex $a_l 0 }] - set list_l [lmap a_l $list_l { lrange $a_l 1 end }] - - if {[join $cur {}] eq {}} { - break - } - lappend zip_l $cur - } - return $zip_l - } - proc lzipn_tcl9a {args} { - #compared to wiki version - #comparable for lists len <3 or number of args < 3 - #approx 2x faster for large lists or more lists - #needs -stride single index bug fix to use empty string instead of NULL - if {![llength $args]} {return {}} - set lens [lmap l $args {llength $l}] - set numcolumns [::tcl::mathfunc::max {*}$lens] - set flatlist [lrepeat [expr {$numcolumns * [llength $args]}] {}] - set outlist [lrepeat $numcolumns {}] - set s 0 - foreach len $lens list $args { - #ledit flatlist $s $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] - ledit flatlist $s [expr {$s + $len - 1}] {*}$list - incr s $numcolumns - } - #needs single index lstride bugfix - for {set c 0} {$c < $numcolumns} {incr c} { - ledit outlist $c $c [lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *] - } - return $outlist - } - proc lzipn_tcl9b {args} { - if {![llength $args]} {return {}} - set lens [lmap l $args {llength $l}] - set numcolumns [::tcl::mathfunc::max {*}$lens] - set flatlist [list] - foreach len $lens list $args { - lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] - } - lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} - } - proc lzipn_tcl9c {args} { - #SLOW - if {![llength $args]} {return {}} - set lens [lmap l $args {llength $l}] - set numcolumns [::tcl::mathfunc::max {*}$lens] - set flatlist [list] - foreach len $lens list $args { - lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] - } - set zip_l {} - set cols_remaining $numcolumns - for {set c 0} {$c < $numcolumns} {incr c} { - if {$cols_remaining == 1} { - return [list {*}$zip_l $flatlist] - } - lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *] - set flen [llength $flatlist] - set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]] - incr cols_remaining -1 - } - return $zip_l - } - #keep both lzipn_tclX functions available for side-by-side testing in Tcl versions where it's possible - if {![package vsatisfies [package present Tcl] 9.0-] || [punk::lib::check::has_tclbug_lsearch_strideallinline ]} { - #-stride either not available - or has bug preventing use of main algorithm below - proc lzipn {args} [info body ::punk::lib::lzipn_tcl8] - } else { - proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a] - } - - - namespace import ::punk::args::lib::tstr - - - - proc invoke command { - #*** !doctools - #[call [fun invoke] [arg command]] - #[para]Invoke an external command (using tcl open command) capturing stdout,stderr and the exitcode - #[example { - # set script { - # puts stdout {hello on stdout} - # puts stderr {hello on stderr} - # exit 42 - # } - # invoke [list tclsh <<$script] - #}] - - #see https://wiki.tcl-lang.org/page/open - lassign [chan pipe] chanout chanin - lappend command 2>@$chanin - set fh [open |$command] - set stdout [read $fh] - close $chanin - set stderr [read $chanout] - close $chanout - if {[catch {close $fh} cres e]} { - dict with e {} - lassign [set -errorcode] sysmsg pid exit - if {$sysmsg eq {NONE}} { - #output to stderr caused [close] to fail. Do nothing - } elseif {$sysmsg eq {CHILDSTATUS}} { - return [list $stdout $stderr $exit] - } else { - return -options $e $stderr - } - } - return [list $stdout $stderr 0] - } - - proc pdict {args} { - package require punk::args - variable has_punk_ansi - if {!$has_punk_ansi} { - 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] { - @id -id ::punk::lib::pdict - @cmd -name pdict -help\ - "Print dict keys,values to channel - The pdict function operates on variable names - passing the value to the showdict function which operates on values - (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 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. - } - }] - #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 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 sep " [a+ Web-seagreen]=[a] " - variable has_punk_ansi - if {!$has_punk_ansi} { - set RST "" - set sep " = " - set sep_mismatch " mismatch " - } else { - set RST [punk::ansi::a] - set sep " [punk::ansi::a+ Green]=$RST " ;#stick to basic default colours for wider terminal support - set sep_mismatch " [punk::ansi::a+ Brightred undercurly underline undt-white]mismatch$RST " - } - package require punk::pipe - #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 -id ::punk::lib::showdict - @cmd -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_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 increasing -choices {increasing decreasing} - -debug -default 0 -type boolean -help\ - "When enabled, produces some rudimentary debug output on stderr" - @values -min 1 -max -1 - dictvalue -type list -help\ - "dict or list value" - patterns -default "*" -type string -multiple 1 -help\ - "key or key glob pattern" - }] $args] - - #for punk::lib - we want to reduce pkg dependencies. - # - so we won't even use the tcllib debug pkg here - set opt_debug [dict get $argd opts -debug] - if {$opt_debug} { - if {[info body debug::showdict] eq ""} { - proc ::punk::lib::debug::showdict {args} { - catch {puts stderr "punk::lib::showdict-> [string cat {*}$args]"} - } - } - } else { - if {[info body debug::showdict] ne ""} { - proc ::punk::lib::debug::showdict {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_keytemplates [dict get $argd opts -keytemplates] - debug::showdict "keytemplates ---> $opt_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] - 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 protect commas that appear within quotes) - set patterninfo [punk::pipe::lib::_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 - if {[string index $p 0] eq "!"} { - set get_not 1 - set p [string range $p 1 end] - } else { - set get_not 0 - } - 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 - } - # { - #todo get_not !# is test for listiness (see punk) - 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 "showdict ---->@*<----" - 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 - # } - #} - if {$get_not} { - lappend keyset [list !$p query] - } else { - 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 {$get_not} { - if {[dict exists $dval $k]} { - set keys [dict keys [dict remove $dval $k]] - lappend keyset {*}$keys - lappend keyset_structure {*}[lrepeat [llength $keys] dict] - } else { - lappend keyset {*}[dict keys $dval] - lappend keyset_structure {*}[lrepeat [dict size $dval] dict] - } - } else { - if {[dict exists $dval $k]} { - lappend keyset $k - lappend keyset_structure dict - } - } - dict set pattern_this_structure $p dict - } - @k@* - @K@* { - #TODO get_not - 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] - if {$get_not} { - lappend keyset [list !$p query] - } else { - lappend keyset [list $p query] - } - lappend keyset_structure dict - dict set pattern_this_structure $p dict - } - {@\*.@*} { - #TODO get_not - 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'" - if {$get_not} { - lappend keyset [list !$p query] - } else { - 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]} { - if {$get_not} { - set keys [punk::lib::range 0 [llength $dval]-1] - set keys [lremove $keys $p] - lappend keyset {*}$keys - lappend keyset_structure {*}[lrepeat [llength $keys] list] - } else { - 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} == -2} { - ##x - #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 == -3} { - ##x - set lower 0 - } else { - set lower $lower_resolve - } - set upper [punk::lib::lindex_resolve $dval $b] - if {$upper == -3} { - ##x - #upper bound is below list range - - if {$lower_resolve >=-2} { - ##x - set upper 0 - } else { - continue - } - } elseif {$upper == -2} { - #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] - if {$get_not} { - set fullrange [punk::lib::range 0 [llength $dval]-1] - set keys [lremove $fullrange {*}$keys] - if {$lower > $upper} { - set keys [lreverse $keys] - } - } - lappend keyset {*}$keys - lappend keyset_structure {*}[lrepeat [llength $keys] list] - } else { - if {$get_not} { - lappend keyset [list !@$p query] - } 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] - if {$get_not} { - set keys [dict keys [dict remove $dval {*}$keys]] - } - 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::pipe::lib::_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} { - #ignore the NOT operator for purposes of query-type detection - if {[string index $pnext 0] eq "!"} { - set pnext [string range $pnext 1 end] - } - # 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 { - 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 - 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 - - 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 - fix - #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 $keydisplay -width $maxl] $opt_sep "$opt_ansibase_values[dict get $dval $key]$RST"] \n - } - } - } - } - if {$opt_trimright} { - set result [::join [lines_as_list -line trimright $result] \n] - } - if {[string last \n $result] == [string length $result]-1} { - set result [string range $result 0 end-1] - } - #stdout/stderr can exist but not be in 'chan names' (e.g when transforms in place) - set chan [dict get $argd opts -channel] - switch -- $chan { - stderr - stdout { - puts $chan $result - } - none { - return $result - } - default { - #review - check member of chan names? - #just try outputting to the supplied channel for now - puts $chan $result - } - } - } - - proc is_list_all_in_list {small large} { - set small_in_large [lsort [struct::set intersect [lsort -unique $small] $large ]] - return [struct::list equal [lsort $small] $small_in_large] - } - if {!$has_struct_list || !$has_struct_set} { - set body { - package require struct::list - package require struct::set - } - append body [info body is_list_all_in_list] - proc is_list_all_in_list {small large} $body - } - - proc is_list_all_ni_list {a b} { - set i [struct::set intersect $a $b] - return [expr {[llength $i] == 0}] - } - if {!$has_struct_set} { - set body { - package require struct::list - } - append body [info body is_list_all_ni_list] - proc is_list_all_ni_list {a b} $body - } - - #somewhat like struct::set difference - but order preserving, and doesn't treat as a 'set' so preserves dupes in fromlist - #struct::set difference may happen to preserve ordering when items are integers, but order can't be relied on, - # especially as struct::set has 2 differing implementations (tcl vs critcl) which return results with different ordering to each other and different deduping behaviour in some cases (e.g empty 2nd arg) - proc ldiff {fromlist removeitems} { - if {[llength $removeitems] == 0} {return $fromlist} - set result {} - foreach item $fromlist { - if {$item ni $removeitems} { - lappend result $item - } - } - return $result - } - proc ldiff2 {fromlist removeitems} { - set doomed [list] - foreach item $removeitems { - lappend doomed {*}[lsearch -all -exact $fromlist $item] - } - lremove $fromlist {*}$doomed - } - - #fix for tcl impl of struct::set::diff which doesn't dedupe - proc struct_set_diff_unique {A B} { - package require struct::set ;#require even if tcl impl - so the dependency isn't missed accidentally due to Loaded state of programmers machine. - if {[struct::set::Loaded] eq "tcl"} { - return [punk::lib::setdiff $A $B] - } else { - #use (presumably critcl) implementation for speed - return [struct::set difference $A $B] - } - } - - - #non-dupe preserving - for consistency in dedupe behaviour we don't shortcircuit empty B - #consistent dedupe and order-maintenance of remaining items in A differentiate this from struct::set difference (dedupes with critcl, doesn't with tcl implementation 2024) - #also struct::set difference with critcl is faster - proc setdiff {A B} { - if {[llength $A] == 0} {return {}} - set d [dict create] - foreach x $A {dict set d $x {}} - foreach x $B {dict unset d $x} - return [dict keys $d] - } - #bulk dict remove is slower than a foreach with dict unset - #proc setdiff2 {fromlist removeitems} { - # #if {[llength $fromlist] == 0} {return {}} - # set d [dict create] - # foreach x $fromlist { - # dict set d $x {} - # } - # return [dict keys [dict remove $d {*}$removeitems]] - #} - #array is about 15% faster than dict - but unordered. (which is ok for sets - but we have struct::set for that) - proc setdiff_unordered {A B} { - if {[llength $A] == 0} {return {}} - array set tmp {} - foreach x $A {::set tmp($x) .} - foreach x $B {catch {unset tmp($x)}} - return [array names tmp] - } - - #default/fallback implementation - proc lunique_unordered {list} { - lunique $list - } - if {$has_struct_set} { - if {[struct::set equal [struct::set union {a a} {}] {a}]} { - proc lunique_unordered {list} { - struct::set union $list {} - } - } else { - puts stderr "WARNING: struct::set union no longer dedupes!" - #we could also test a sequence of: struct::set add - } - } - - - #order-preserving - proc lunique {list} { - set new {} - foreach item $list { - if {$item ni $new} { - lappend new $item - } - } - return $new - } - proc lunique2 {list} { - set doomed [list] - #expr 'in' probably faster than using a dict - for lists approx < 20,000 items. (wiki wisdom - url?) - for {set i 0} {$i < [llength $list]} {} { - set item [lindex $list $i] - lappend doomed {*}[lrange [lsearch -all -exact -start $i $list $item] 1 end] - while {[incr i] in $doomed} {} - } - lremove $list {*}$doomed - } - #The closure-like behaviour is *very* slow especially when called from a context such as the global namespace with lots of vars and large arrays such as ::env - proc lmapflat_closure {varnames list script} { - set result [list] - set values [list] - foreach v $varnames { - lappend values "\$$v" - } - # -- --- --- - #capture - use uplevel 1 or namespace eval depending on context - set capture [uplevel 1 { - apply { varnames { - set capturevars [tcl::dict::create] - set capturearrs [tcl::dict::create] - foreach fullv $varnames { - set v [tcl::namespace::tail $fullv] - upvar 1 $v var - if {[info exists var]} { - if {(![array exists var])} { - tcl::dict::set capturevars $v $var - } else { - tcl::dict::set capturearrs capturedarray_$v [array get var] - } - } else { - #A variable can show in the results for 'info vars' but still not 'exist'. e.g a 'variable x' declaration in the namespace where the variable has never been set - } - } - return [tcl::dict::create vars $capturevars arrs $capturearrs] - } } [info vars] - } ] - # -- --- --- - set cvars [tcl::dict::get $capture vars] - set carrs [tcl::dict::get $capture arrs] - set apply_script "" - foreach arrayalias [tcl::dict::keys $carrs] { - set realname [string range $arrayalias [string first _ $arrayalias]+1 end] - append apply_script [string map [list %realname% $realname %arrayalias% $arrayalias] { - array set %realname% [set %arrayalias%][unset %arrayalias%] - }] - } - - append apply_script [string map [list %script% $script] { - #foreach arrayalias [info vars capturedarray_*] { - # set realname [string range $arrayalias [string first _ $arrayalias]+1 end] - # array set $realname [set $arrayalias][unset arrayalias] - #} - #return [eval %script%] - %script% - }] - #puts "--> $apply_script" - foreach $varnames $list { - lappend result {*}[apply\ - [list\ - [concat $varnames [tcl::dict::keys $cvars] [tcl::dict::keys $carrs] ]\ - $apply_script\ - ] {*}[subst $values] {*}[tcl::dict::values $cvars] {*}[tcl::dict::values $carrs] ] - } - return $result - } - #link version - can write to vars in calling context - but keeps varnames themselves isolated - #performance much better than capture version - but still a big price to pay for the isolation - proc lmapflat_link {varnames list script} { - set result [list] - set values [list] - foreach v $varnames { - lappend values "\$$v" - } - set linkvars [uplevel 1 [list info vars]] - set nscaller [uplevel 1 [list namespace current]] - - set apply_script "" - foreach vname $linkvars { - append apply_script [string map [list %vname% $vname]\ - {upvar 2 %vname% %vname%}\ - ] \n - } - append apply_script $script \n - - #puts "--> $apply_script" - foreach $varnames $list { - lappend result {*}[apply\ - [list\ - $varnames\ - $apply_script\ - $nscaller\ - ] {*}[subst $values]\ - ] - } - return $result - } - - #proc lmapflat {varnames list script} { - # concat {*}[uplevel 1 [list lmap $varnames $list $script]] - #} - #lmap can accept multiple var list pairs - proc lmapflat {args} { - concat {*}[uplevel 1 [list lmap {*}$args]] - } - proc lmapflat2 {args} { - concat {*}[uplevel 1 lmap {*}$args] - } - - #proc dict_getdef {dictValue args} { - # if {[llength $args] < 1} { - # error {wrong # args: should be "dict_getdef dictValue ?key ...? key default"} - # } - # set keys [lrange $args -1 end-1] - # if {[tcl::dict::exists $dictValue {*}$keys]} { - # return [tcl::dict::get $dictValue {*}$keys] - # } else { - # return [lindex $args end] - # } - #} - if {[info commands ::tcl::dict::getdef] eq ""} { - proc dict_getdef {dictValue args} { - set keys [lrange $args 0 end-1] - if {[tcl::dict::exists $dictValue {*}$keys]} { - return [tcl::dict::get $dictValue {*}$keys] - } else { - return [lindex $args end] - } - } - } else { - #we pay a minor perf penalty for the wrap - interp alias "" ::punk::lib::dict_getdef "" ::tcl::dict::getdef - } - - - #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" - #} - - #supports *safe* ultra basic offset expressions as used by lindex etc, but without the 'end' features - #safe in that we don't evaluate the expression as a string. - proc offset_expr {expression} { - set expression [tcl::string::map {_ {}} $expression] - if {[tcl::string::is integer -strict $expression]} { - return [expr {$expression}] - } - if {[regexp {(.*)([+-])(.*)} $expression _match a op b] && [tcl::string::is integer -strict $a] && [tcl::string::is integer -strict $b]} { - if {$op eq "-"} { - return [expr {$a - $b}] - } else { - return [expr {$a + $b}] - } - } else { - error "bad expression '$expression': must be integer?\[+-\]integer?" - } - } - - # showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bunds on upper vs lower side - proc lindex_resolve {list index} { - #*** !doctools - #[call [fun lindex_resolve] [arg list] [arg index]] - #[para]Resolve an index which may be of the forms accepted by Tcl list commands such as end-2 or 2+2 to the actual integer index for the supplied list - #[para]Users may define procs which accept a list index and wish to accept the forms understood by Tcl. - #[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: - #[para] a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0) - #[para] b) -2 if the supplied index expression is above the upper bound for the supplied list. (> end) - #[para] We don't return -1 - as the similar function lindex_resolve_basic uses this to denote out of range at either end of the list - #[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 - #[para]For empty lists, end and end+x indices are considered to be out of bounds on the upper side - thus returning -2 - - #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]} { - # #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 -3 - } elseif {$index >= [llength $list]} { - return -2 - } else { - #integer may still have + sign - normalize with expr - return [expr {$index}] - } - } else { - if {[string match end* $index]} { - 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 -2 - } - } else { - #index is '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 -2 - } else { - return $index - } - } - if {$offset == 0} { - set index [expr {[llength $list]-1}] - if {$index < 0} { - return -2 ;#special case as above - } 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 -3 - } else { - return $index - } - } else { - #plain +- already handled above. - #we are trying to avoid evaluating unbraced expr of potentially insecure origin - 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?" - } - if {$index < 0} { - return -3 - } elseif {$index >= [llength $list]} { - return -2 - } - return $index - } - } - } - proc lindex_resolve_basic {list index} { - #*** !doctools - #[call [fun lindex_resolve_basic] [arg list] [arg index]] - #[para] Accepts index of the forms accepted by Tcl's list commands. (e.g compound indices such as 3+1 end-2) - #[para] returns -1 for out of range at either end, or a valid integer index - #[para] Unlike lindex_resolve; lindex_resolve_basic can't determine if an out of range index was out of range at the lower or upper bound - #[para] This is only likely to be faster than average over lindex_resolve for Tcl which has the builtin lseq command - #[para] The performance advantage is more likely to be present when using compound indexes such as $x+1 or end-1 - #[para] For pure integer indices the performance should be equivalent - - #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+ - # - which - #for {set i 0} {$i < [llength $list]} {incr i} { - # lappend indices $i - #} - set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 - if {[string is integer -strict $index]} { - #can match +i -i - #avoid even the lseq overhead when the index is simple - if {$index < 0 || ($index >= [llength $list])} { - #even though in this case we could return -2 or -3 like lindex_resolve; for consistency we don't, as it's not always determinable for compound indices using the lseq method. - return -1 - } else { - #integer may still have + sign - normalize with expr - return [expr {$index}] - } - } - if {[llength $list]} { - set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback. - #if lseq was available - $indices is an 'arithseries' - theoretically not taking up ram(?) - } else { - set indices [list] - } - set idx [lindex $indices $index] - if {$idx eq ""} { - #we have no way to determine if out of bounds is at lower vs upper end - return -1 - } else { - return $idx - } - } - proc lindex_get {list index} { - set resultlist [lrange $list $index $index] - if {![llength $resultlist]} { - return -1 - } else { - #we still don't know the actual integer index for an index such as end-x or int-int without parsing and evaluating ourself. - #we can return the value - but only in a way that won't collide with our -1 out-of-range indicator - return [tcl::dict::create value [lindex $resultlist 0]] - } - } - - - proc K {x y} {return $x} - #*** !doctools - #[call [fun K] [arg x] [arg y]] - #[para]The K-combinator function - returns the first argument, x and discards y - #[para]see [uri https://wiki.tcl-lang.org/page/K] - #[para]It is used in cases where command-substitution at the calling-point performs some desired effect. - - - proc is_utf8_multibyteprefix {bytes} { - #*** !doctools - #[call [fun is_utf8_multibyteprefix] [arg str]] - #[para] Returns a boolean if str is potentially a prefix for a multibyte utf-8 character - #[para] ie - tests if it is possible that appending more data will result in a utf-8 codepoint - #[para] Will return false for an already complete utf-8 codepoint - #[para] It is assumed the incomplete sequence is at the beginning of the bytes argument - #[para] Suitable input for this might be from the unreturned tail portion of get_utf8_leading $testbytes - #[para] e.g using: set head [lb]get_utf8_leading $testbytes[rb] ; set tail [lb]string range $testbytes [lb]string length $head[rb] end[rb] - regexp {(?x) - ^ - (?: - [\xC0-\xDF] | #possible prefix for two-byte codepoint - [\xE0-\xEF] [\x80-\xBF]{0,1} | #possible prefix for three-byte codepoint - [\xF0-\xF4] [\x80-\xBF]{0,2} #possible prefix for - ) - $ - } $bytes - } - - proc is_utf8_first {str} { - regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) - ^ - (?: - [\x00-\x7F] | # Single-byte chars (ASCII range) - [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) - [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) - [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) - ) - } $str - } - proc is_utf8_single {1234bytes} { - #*** !doctools - #[call [fun is_utf8_single] [arg 1234bytes]] - #[para] Tests input of 1,2,3 or 4 bytes and responds with a boolean indicating if it is a valid utf-8 character (codepoint) - regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) - ^ - (?: - [\x00-\x7F] | # Single-byte chars (ASCII range) - [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) - [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) - [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) - ) - $ - } $1234bytes - } - proc get_utf8_leading {rawbytes} { - #*** !doctools - #[call [fun get_utf8_leading] [arg rawbytes]] - #[para] return the leading portion of rawbytes that is a valid utf8 sequence. - #[para] This will stop at the point at which the bytes can't be interpreted as a complete utf-8 codepoint - #[para] e.g It will not return the first byte or 2 of a 3-byte utf-8 character if the last byte is missing, and will return only the valid utf-8 string from before the first byte of the incomplete character. - #[para] It will also only return the prefix before any bytes that cannot be part of a utf-8 sequence at all. - #[para] Note that while this will return valid utf8 - it has no knowledge of grapheme clusters or diacritics - #[para] This means if it is being used to process bytes split at some arbitrary point - the trailing data that isn't returned could be part of a grapheme cluster that belongs with the last character of the leading string already returned - #[para] The utf-8 BOM \xEF\xBB\xBF is a valid UTF8 3-byte sequence and so can also be returned as part of the leading utf8 bytes - if {[regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) - \A ( - [\x00-\x7F] | # Single-byte chars (ASCII range) - [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) - [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) - [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) - ) + - } $rawbytes completeChars]} { - return $completeChars - } - return "" - } - proc hex2dec {args} { - #*** !doctools - #[call [fun hex2dec] [opt {option value...}] [arg list_largeHex]] - #[para]Convert a list of (possibly large) unprefixed hex strings to their decimal values - #[para]hex2dec accepts and ignores internal underscores in the same manner as Tcl 8.7+ numbers e.g hex2dec FF_FF returns 65535 - #[para]Leading and trailing underscores are ignored as a matter of implementation convenience - but this shouldn't be relied upon. - #[para]Leading or trailing whitespace in each list member is allowed e.g hex2dec " F" returns 15 - #[para]Internal whitespace e.g "F F" is not permitted - but a completely empty element "" is allowed and will return 0 - - set list_largeHex [lindex $args end] - set argopts [lrange $args 0 end-1] - if {[llength $argopts]%2 !=0} { - error "[namespace current]::hex2dec arguments prior to list_largeHex must be option/value pairs - received '$argopts'" - } - set opts [tcl::dict::create\ - -validate 1\ - -empty_as_hex "INVALID set -empty_as_hex to a hex string e.g FF if empty values should be replaced"\ - ] - set known_opts [tcl::dict::keys $opts] - foreach {k v} $argopts { - tcl::dict::set opts [tcl::prefix match -message "options for hex2dec. Unexpected option" $known_opts $k] $v - } - # -- --- --- --- - set opt_validate [tcl::dict::get $opts -validate] - set opt_empty [tcl::dict::get $opts -empty_as_hex] - # -- --- --- --- - - set list_largeHex [lmap h $list_largeHex[unset list_largeHex] {string map {_ ""} [string trim $h]}] - if {$opt_validate} { - #Note appended F so that we accept list of empty strings as per the documentation - if {![string is xdigit -strict [join $list_largeHex ""]F ]} { - error "[namespace current]::hex2dec error: non-hex digits encountered after stripping underscores and leading/trailing whitespace for each element\n $list_largeHex" - } - } - if {![string is xdigit -strict [string map {_ ""} $opt_empty]]} { - #mapping empty string to a value destroys any advantage of -scanonly - #todo - document that -scanonly has 2 restrictions - each element must be valid hex and less than 7 chars long - #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {0} : {[set v]}}] - if {[lsearch $list_largeHex ""] >=0} { - error "[namespace current]::hex2dec error: empty values in list cannot be mapped to non-hex $opt_empty" - } - } else { - set opt_empty [string trim [string map {_ ""} $opt_empty]] - if {[set first_empty [lsearch $list_largeHex ""]] >= 0} { - #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {$opt_empty} : {$v}}] - set nonempty_head [lrange $list_largeHex 0 $first_empty-1] - set list_largeHex [concat $nonempty_head [lmap v [lrange $list_largeHex $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] - } - } - return [scan $list_largeHex [string repeat %llx [llength $list_largeHex]]] - } - - proc dec2hex {args} { - #*** !doctools - #[call [fun dex2hex] [opt {option value...}] [arg list_decimals]] - #[para]Convert a list of decimal integers to a list of hex values - #[para] -width can be used to make each hex value at least int characters wide, with leading zeroes. - #[para] -case upper|lower determines the case of the hex letters in the output - set list_decimals [lindex $args end] - set argopts [lrange $args 0 end-1] - if {[llength $argopts]%2 !=0} { - error "[namespace current]::dec2hex arguments prior to list_decimals must be option/value pairs - received '$argopts'" - } - set defaults [tcl::dict::create\ - -width 1\ - -case upper\ - -empty_as_decimal "INVALID set -empty_as_decimal to a number if empty values should be replaced"\ - ] - set known_opts [tcl::dict::keys $defaults] - set fullopts [tcl::dict::create] - foreach {k v} $argopts { - tcl::dict::set fullopts [tcl::prefix match -message "options for [tcl::namespace::current]::dec2hex. Unexpected option" $known_opts $k] $v - } - set opts [tcl::dict::merge $defaults $fullopts] - # -- --- --- --- - set opt_width [tcl::dict::get $opts -width] - set opt_case [tcl::dict::get $opts -case] - set opt_empty [tcl::dict::get $opts -empty_as_decimal] - # -- --- --- --- - - - set resultlist [list] - switch -- [string tolower $opt_case] { - upper { - set spec X - } - lower { - set spec x - } - default { - error "[namespace current]::dec2hex unknown value '$opt_case' for -case expected upper|lower" - } - } - set fmt "%${opt_width}.${opt_width}ll${spec}" - - set list_decimals [lmap d $list_decimals[unset list_decimals] {string map {_ ""} [string trim $d]}] - if {![string is digit -strict [string map {_ ""} $opt_empty]]} { - if {[lsearch $list_decimals ""] >=0} { - error "[namespace current]::dec2hex error: empty values in list cannot be mapped to non-decimal $opt_empty" - } - } else { - set opt_empty [string map {_ ""} $opt_empty] - if {[set first_empty [lsearch $list_decimals ""]] >= 0} { - set nonempty_head [lrange $list_decimals 0 $first_empty-1] - set list_decimals [concat $nonempty_head [lmap v [lrange $list_decimals $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] - } - } - return [format [lrepeat [llength $list_decimals] $fmt] {*}$list_decimals] - } - - proc log2 x "expr {log(\$x)/[expr log(2)]}" - #*** !doctools - #[call [fun log2] [arg x]] - #[para]log base2 of x - #[para]This uses a 'live' proc body - the divisor for the change of base is computed once at definition time - #[para](courtesy of RS [uri https://wiki.tcl-lang.org/page/Additional+math+functions]) - - proc logbase {b x} { - #*** !doctools - #[call [fun logbase] [arg b] [arg x]] - #[para]log base b of x - #[para]This function uses expr's natural log and the change of base division. - #[para]This means for example that we can get results like: logbase 10 1000 = 2.9999999999999996 - #[para]Use expr's log10() function or tcl::mathfunc::log10 for base 10 - expr {log($x)/log($b)} - } - proc factors {x} { - #*** !doctools - #[call [fun factors] [arg x]] - #[para]Return a sorted list of the positive factors of x where x > 0 - #[para]For x = 0 we return only 0 and 1 as technically any number divides zero and there are an infinite number of factors. (including zero itself in this context)* - #[para]This is a simple brute-force implementation that iterates all numbers below the square root of x to check the factors - #[para]Because the implementation is so simple - the performance is very reasonable for numbers below at least a few 10's of millions - #[para]See tcllib math::numtheory::factors for a more complex implementation - which seems to be slower for 'small' numbers - #[para]Comparisons were done with some numbers below 17 digits long - #[para]For seriously big numbers - this simple algorithm would no doubt be outperformed by more complex algorithms. - #[para]The numtheory library stores some data about primes etc with each call - so may become faster when being used on more numbers - #but has the disadvantage of being slower for 'small' numbers and using more memory. - #[para]If the largest factor below x is needed - the greatestOddFactorBelow and GreatestFactorBelow functions are a faster way to get there than computing the whole list, even for small values of x - #[para]* Taking x=0; Notion of x being divisible by integer y being: There exists an integer p such that x = py - #[para] In other mathematical contexts zero may be considered not to divide anything. - set factors [list 1] - set j 2 - set max [expr {sqrt($x)}] - while {$j <= $max} { - if {($x % $j) == 0} { - lappend factors $j [expr {$x / $j}] - } - incr j - } - lappend factors $x - return [lsort -unique -integer $factors] - } - proc oddFactors {x} { - #*** !doctools - #[call [fun oddFactors] [arg x]] - #[para]Return a list of odd integer factors of x, sorted in ascending order - set j 2 - set max [expr {sqrt($x)}] - set factors [list 1] - while {$j <= $max} { - if {$x % $j == 0} { - set other [expr {$x / $j}] - if {$other % 2} { - if {$other ni $factors} { - lappend factors $other - } - } - if {$j % 2} { - if {$j ni $factors} { - lappend factors $j - } - } - } - incr j - } - return [lsort -integer -increasing $factors] - } - proc greatestFactorBelow {x} { - #*** !doctools - #[call [fun greatestFactorBelow] [arg x]] - #[para]Return the largest factor of x excluding itself - #[para]factor functions can be useful for console layout calculations - #[para]See Tcllib math::numtheory for more extensive implementations - if {$x % 2 == 0 || $x == 0} { - return [expr {$x / 2}] - } - set j 3 - set max [expr {sqrt($x)}] - while {$j <= $max} { - if {$x % $j == 0} { - return [expr {$x / $j}] - } - incr j 2 - } - return 1 - } - proc greatestOddFactorBelow {x} { - #*** !doctools - #[call [fun greatestOddFactorBelow] [arg x]] - #[para]Return the largest odd integer factor of x excluding x itself - if {$x %2 == 0} { - return [greatestOddFactor $x] - } - set j 3 - #dumb brute force - time taken to compute is wildly variable on big numbers - #todo - use a (memoized?) generator of primes to reduce the search space - #tcllib math::numtheory has suitable functions - but do we want that dependency here? Testing shows brute-force often faster for small numbers. - set god 1 - set max [expr {sqrt($x)}] - while { $j <= $max} { - if {$x % $j == 0} { - set other [expr {$x / $j}] - if {$other % 2 == 0} { - set god $j - } else { - set god [expr {$x / $j}] - #lowest j - so other side must be highest - break - } - } - incr j 2 - } - return $god - } - proc greatestOddFactor {x} { - #*** !doctools - #[call [fun greatestOddFactor] [arg x]] - #[para]Return the largest odd integer factor of x - #[para]For an odd value of x - this will always return x - if {$x % 2 != 0 || $x == 0} { - return $x - } - set r [expr {$x / 2}] - while {$r % 2 == 0} { - set r [expr {$r / 2}] - } - return $r - } - proc gcd {n m} { - #*** !doctools - #[call [fun gcd] [arg n] [arg m]] - #[para]Return the greatest common divisor of m and n - #[para]Straight from Lars Hellström's math::numtheory library in Tcllib - #[para]Graphical use: - #[para]An a by b rectangle can be covered with square tiles of side-length c, - #[para]only if c is a common divisor of a and b - - # - # Apply Euclid's good old algorithm - # - if { $n > $m } { - set t $n - set n $m - set m $t - } - - while { $n > 0 } { - set r [expr {$m % $n}] - set m $n - set n $r - } - - return $m - } - proc lcm {n m} { - #*** !doctools - #[call [fun gcd] [arg n] [arg m]] - #[para]Return the lowest common multiple of m and n - #[para]Straight from Lars Hellström's math::numtheory library in Tcllib - #[para] - set gcd [gcd $n $m] - return [expr {$n*$m/$gcd}] - } - proc commonDivisors {x y} { - #*** !doctools - #[call [fun commonDivisors] [arg x] [arg y]] - #[para]Return a list of all the common factors of x and y - #[para](equivalent to factors of their gcd) - return [factors [gcd $x $y]] - } - - #experimental only - there are better/faster ways - proc sieve n { - set primes [list] - if {$n < 2} {return $primes} - set nums [tcl::dict::create] - for {set i 2} {$i <= $n} {incr i} { - tcl::dict::set nums $i "" - } - set next 2 - set limit [expr {sqrt($n)}] - while {$next <= $limit} { - for {set i $next} {$i <= $n} {incr i $next} {tcl::dict::unset nums $i} - lappend primes $next - tcl::dict::for {next -} $nums break - } - return [concat $primes [tcl::dict::keys $nums]] - } - proc sieve2 n { - set primes [list] - if {$n < 2} {return $primes} - set nums [tcl::dict::create] - for {set i 2} {$i <= $n} {incr i} { - tcl::dict::set nums $i "" - } - set next 2 - set limit [expr {sqrt($n)}] - while {$next <= $limit} { - for {set i $next} {$i <= $n} {incr i $next} {tcl::dict::unset nums $i} - lappend primes $next - #dict for {next -} $nums break - set next [lindex $nums 0] - } - return [concat $primes [tcl::dict::keys $nums]] - } - - proc hasglobs {str} { - #*** !doctools - #[call [fun hasglobs] [arg str]] - #[para]Return a boolean indicating whether str contains any of the glob characters: * ? [lb] [rb] - #[para]hasglobs uses append to preserve Tcls internal representation for str - so it should help avoid shimmering in the few cases where this may matter. - regexp {[*?\[\]]} [append obj2 $str {}] ;# int-rep preserving - } - - proc trimzero {number} { - #*** !doctools - #[call [fun trimzero] [arg number]] - #[para]Return number with left-hand-side zeros trimmed off - unless all zero - #[para]If number is all zero - a single 0 is returned - set trimmed [string trimleft $number 0] - if {[string length $trimmed] == 0} { - set trimmed 0 - } - return $trimmed - } - proc substring_count {str substring} { - #*** !doctools - #[call [fun substring_count] [arg str] [arg substring]] - #[para]Search str and return number of occurrences of substring - - #faster than lsearch on split for str of a few K - if {$substring eq ""} {return 0} - set occurrences [expr {[string length $str]-[string length [string map [list $substring {}] $str]]}] - return [expr {$occurrences / [string length $substring]}] - } - - proc dict_merge_ordered {defaults main} { - #*** !doctools - #[call [fun dict_merge_ordered] [arg defaults] [arg main]] - #[para]The standard dict merge accepts multiple dicts with values from dicts to the right (2nd argument) taking precedence. - #[para]When merging with a dict of default values - this means that any default key/vals that weren't in the main dict appear in the output before the main data. - #[para]This function merges the two dicts whilst maintaining the key order of main followed by defaults. - - #1st merge (inner merge) with wrong values taking precedence - but right key-order - then (outer merge) restore values - return [tcl::dict::merge [tcl::dict::merge $main $defaults] $main] - } - - proc askuser {question} { - #*** !doctools - #[call [fun askuser] [arg question]] - #[para]A basic utility to read an answer from stdin - #[para]The prompt is written to the terminal and then it waits for a user to type something - #[para]stdin is temporarily configured to blocking and then put back in its original state in case it wasn't already so. - #[para]If the terminal is using punk::console and is in raw mode - the terminal will temporarily be put in line mode. - #[para](Generic terminal raw vs linemode detection not yet present) - #[para]The user must hit enter to submit the response - #[para]The return value is the string if any that was typed prior to hitting enter. - #[para]The question argument can be manually colourised using the various punk::ansi funcitons - #[example_begin] - # set answer [lb]punk::lib::askuser "[lb]a+ green bold[rb]Do you want to proceed? (Y|N)[lb]a[rb]"[rb] - # if {[lb]string match y* [lb]string tolower $answer[rb][rb]} { - # puts "Proceeding" - # } else { - # puts "Cancelled by user" - # } - #[example_end] - puts stdout $question - flush stdout - set stdin_state [chan configure stdin] - if {[catch { - package require punk::console - set console_raw [tsv::get console is_raw] - } err_console]} { - #assume normal line mode - set console_raw 0 - } - try { - chan configure stdin -blocking 1 - if {$console_raw} { - punk::console::disableRaw - set answer [gets stdin] - punk::console::enableRaw - } else { - set answer [gets stdin] - } - } finally { - chan configure stdin -blocking [tcl::dict::get $stdin_state -blocking] - } - return $answer - } - - #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. - proc indent {text {prefix " "}} { - set result [list] - foreach line [split $text \n] { - if {[string trim $line] eq ""} { - lappend result "" - } else { - lappend result $prefix[string trimright $line] - } - } - return [join $result \n] - } - #dedent? - proc undent {text} { - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - regexp {^([\t ]*)} $lcp _m lcp - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - #A version of textutil::string::longestCommonPrefixList - proc longestCommonPrefix {items} { - if {[llength $items] <= 1} { - return [lindex $items 0] - } - set items [lsort $items[unset items]] - set min [lindex $items 0] - set max [lindex $items end] - #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) - #(sort order nothing to do with length - e.g min may be longer than max) - if {[string length $min] > [string length $max]} { - set temp $min - set min $max - set max $temp - } - set n [string length $min] - set prefix "" - set i -1 - while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { - append prefix $c - } - return $prefix - } - - #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 - #[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 ? " - } - 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 [tcl::dict::values [punk::args::get_dict { - -joinchar -default \n - @values -min 1 -max 1 - } $args]] leaders opts values - puts "opts:$opts" - puts "values:$values" - return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]] - } - - proc lines_as_list {args} { - #*** !doctools - #[call [fun lines_as_list] [opt {option value ...}] [arg text]] - #[para]Returns a list of possibly trimmed lines depeding on options - #[para]The concept of lines is raw lines from splitting on newline after crlf is mapped to lf - #[para]- not console lines which may be entirely different due to control characters such as vertical tabs or ANSI movements - - #The underlying function linelist has the validation code which gives nicer 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 [tcl::dict::merge {-block {}} $opts] - set bposn [lsearch $opts -block] - if {$bposn < 0} { - lappend opts -block {} - } - set text [lindex $args end] - #tailcall linelist {*}$opts $text - return [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 [tcl::dict::values [punk::args::get_dict { - @opts -any 1 - -block -default {} - } $args]] leaderdict opts valuedict - tailcall linelist {*}$opts {*}[tcl::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 - set linelist_body { - set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" - if {[llength $args] == 0} { - error "linelist missing textchunk argument usage:$usage" - } - set text [lindex $args end] - set text [string map {\r\n \n} $text] ;#review - option? - - set arglist [lrange $args 0 end-1] - set opts [tcl::dict::create\ - -block {trimhead1 trimtail1}\ - -line {}\ - -commandprefix ""\ - -ansiresets auto\ - -ansireplays 0\ - ] - foreach {o v} $arglist { - switch -- $o { - -block - -line - -commandprefix - -ansiresets - -ansireplays { - tcl::dict::set opts $o $v - } - default { - error "linelist: Unrecognized option '$o' usage:$usage" - } - } - } - # -- --- --- --- --- --- - set opt_block [tcl::dict::get $opts -block] - if {[llength $opt_block]} { - foreach bo $opt_block { - switch -- $bo { - trimhead - trimtail - triminner - trimall - trimhead1 - trimtail1 - collateempty {} - default { - set known_blockopts [list trimhead trimtail triminner trimall trimhead1 trimtail1 collateempty] - error "linelist: unknown -block option value: $bo known values: $known_blockopts" - } - } - } - #normalize certain combos - if {"trimhead" in $opt_block && [set posn [lsearch $opt_block trimhead1]] >=0} { - set opt_block [lreplace $opt_block $posn $posn] - } - if {"trimtail" in $opt_block && [set posn [lsearch $opt_block trimtail1]] >=0} { - 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 [tcl::dict::get $opts -line] - set tl_left 0 - set tl_right 0 - set tl_both 0 - foreach lo $opt_line { - switch -- $lo { - trimline { - set tl_both 1 - } - trimleft { - set tl_left 1 - } - trimright { - set tl_right 1 - } - default { - set known_lineopts [list trimline trimleft trimright] - error "linelist: unknown -line option value: $lo known values: $known_lineopts" - } - } - } - #normalize trimleft trimright combo - if {$tl_left && $tl_right} { - set opt_line [list "trimline"] - set tl_both 1 - } - # -- --- --- --- --- --- - set opt_commandprefix [tcl::dict::get $opts -commandprefix] - # -- --- --- --- --- --- - set opt_ansiresets [tcl::dict::get $opts -ansiresets] - # -- --- --- --- --- --- - set opt_ansireplays [tcl::dict::get $opts -ansireplays] - if {$opt_ansireplays} { - if {$opt_ansiresets eq "auto"} { - set opt_ansiresets 1 - } - } else { - if {$opt_ansiresets eq "auto"} { - set opt_ansiresets 0 - } - } - # -- --- --- --- --- --- - set linelist [list] - set nlsplit [split $text \n] - if {![llength $opt_line]} { - set linelist $nlsplit - #lappend linelist {*}$nlsplit - } else { - #already normalized trimleft+trimright to trimline - if {$tl_both} { - foreach ln $nlsplit { - lappend linelist [string trim $ln] - } - } elseif {$tl_left} { - foreach ln $nlsplit { - lappend linelist [string trimleft $ln] - } - } elseif {$tl_right} { - foreach ln $nlsplit { - 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] - } - - #review - we need to make sure ansiresets don't accumulate/grow on any line - #Each resulting line should have a reset of some type at start and a pure-reset at end to stop - #see if we can find an ST sequence that most terminals will not display for marking sections? - if {$opt_ansireplays} { - #package require punk::ansi - - if {$opt_ansiresets} { - set RST "\x1b\[0m" - } else { - set RST "" - } - set replaycodes $RST ;#todo - default? - set transformed [list] - #shortcircuit common case of no ansi - #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. - #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) - #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable - #detect_in_list will check at first level. (not intended for detecting ansi in deeper structures) - if {![punk::ansi::ta::detect_in_list $linelist]} { - if {$opt_ansiresets} { - foreach ln $linelist { - lappend transformed $RST$ln$RST - } - set linelist $transformed - } - } else { - - #INLINE punk::ansi::codetype::is_sgr_reset - #regexp {\x1b\[0*m$} $code - set re_is_sgr_reset {\x1b\[0*m$} - #INLINE punk::ansi::codetype::is_sgr - #regexp {\033\[[0-9;:]*m$} $code - set re_is_sgr {\x1b\[[0-9;:]*m$} - - foreach ln $linelist { - #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable - - #set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. - #get_codes_single lists only the codes. no plaintext or empty elements - set ansisplits [punk::ansi::ta::get_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. - if {[llength $ansisplits] == 0} { - #plaintext only - no ansi codes in line - lappend transformed [string cat $replaycodes $ln $RST] - #leave replaycodes as is for next line - set nextreplay $replaycodes - } else { - set tail $RST - set lastcode [lindex $ansisplits end] ;#may or may not be SGR - set lastcodeoffset [expr {[string length $lastcode]-1}] - if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { - if {[string range $ln end-$lastcodeoffset end] eq $lastcode} { - #last plaintext is empty. So the line is already suffixed with a reset - set tail "" - set nextreplay $RST - } else { - #trailing text has been reset within line - but no tail reset present - #we normalize by putting a tail reset on anyway - set tail $RST - set nextreplay $RST - } - } elseif {[string range $ln end-$lastcodeoffset end] eq $lastcode && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { - #code is at tail (no trailing plaintext) - #No tail reset - and no need to examine whole line to determine stack that is in effect - set tail $RST - set nextreplay $lastcode - } else { - #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect - #last codeset doesn't end in a pure-reset - #whether code was at very end or not - add a reset tail - set tail $RST - #determine effective replay for line - set codestack [list start] - foreach code $ansisplits { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set codestack [list] ;#different from 'start' marked - this means we've had a reset - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set codestack [list $code] - } else { - if {[punk::ansi::codetype::is_sgr $code]} { - #todo - proper test of each code - so we only take latest background/foreground etc. - #requires handling codes with varying numbers of parameters. - #basic simplification - remove straight dupes. - set dup_posns [lsearch -all -exact $codestack $code] ;#!must use -exact as codes have square brackets which are interpreted as glob chars. - set codestack [lremove $codestack {*}$dup_posns] - lappend codestack $code - } ;#else gx0 or other code - we don't want to stack it with SGR codes - } - } - if {$codestack eq [list start]} { - #No SGRs - may have been other codes - set line_has_sgr 0 - } else { - #list is either empty or begins with start - empty means it had SGR reset - so it still invalidates current state of replaycodes - set line_has_sgr 1 - if {[lindex $codestack 0] eq "start"} { - set codestack [lrange $codestack 1 end] - } - } - - #set newreplay [join $codestack ""] - set newreplay [punk::ansi::codetype::sgr_merge_list {*}$codestack] - - if {$line_has_sgr && $newreplay ne $replaycodes} { - #adjust if it doesn't already does a reset at start - if {[punk::ansi::codetype::has_sgr_leadingreset $newreplay]} { - set nextreplay $newreplay - } else { - set nextreplay $RST$newreplay - } - } else { - set nextreplay $replaycodes - } - } - if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { - #no point attaching any replay - lappend transformed [string cat $ln $tail] - } else { - lappend transformed [string cat $replaycodes $ln $tail] - } - } - set replaycodes $nextreplay - } - set linelist $transformed - } - } - - if {[llength $opt_commandprefix]} { - set transformed [list] - foreach ln $linelist { - lappend transformed [{*}$opt_commandprefix $ln] - } - set linelist $transformed - } - - return $linelist - } - if {$has_punk_ansi} { - #optimise linelist as much as possible - set linelist_body [string map { ""} $linelist_body] - } else { - #punk ansi not avail at time of package load. - #by putting in calls to punk::ansi the user will get appropriate error messages - set linelist_body [string map { "package require punk::ansi"} $linelist_body] - } - - set linelist_body_original { - set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" - if {[llength $args] == 0} { - error "linelist missing textchunk argument usage:$usage" - } - set text [lindex $args end] - set text [string map {\r\n \n} $text] ;#review - option? - - set arglist [lrange $args 0 end-1] - set opts [tcl::dict::create\ - -block {trimhead1 trimtail1}\ - -line {}\ - -commandprefix ""\ - -ansiresets auto\ - -ansireplays 0\ - ] - foreach {o v} $arglist { - switch -- $o { - -block - -line - -commandprefix - -ansiresets - -ansireplays { - tcl::dict::set opts $o $v - } - default { - error "linelist: Unrecognized option '$o' usage:$usage" - } - } - } - # -- --- --- --- --- --- - set opt_block [tcl::dict::get $opts -block] - if {[llength $opt_block]} { - foreach bo $opt_block { - switch -- $bo { - trimhead - trimtail - triminner - trimall - trimhead1 - trimtail1 - collateempty {} - default { - set known_blockopts [list trimhead trimtail triminner trimall trimhead1 trimtail1 collateempty] - error "linelist: unknown -block option value: $bo known values: $known_blockopts" - } - } - } - #normalize certain combos - if {"trimhead" in $opt_block && [set posn [lsearch $opt_block trimhead1]] >=0} { - set opt_block [lreplace $opt_block $posn $posn] - } - if {"trimtail" in $opt_block && [set posn [lsearch $opt_block trimtail1]] >=0} { - 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 [tcl::dict::get $opts -line] - set tl_left 0 - set tl_right 0 - set tl_both 0 - foreach lo $opt_line { - switch -- $lo { - trimline { - set tl_both 1 - } - trimleft { - set tl_left 1 - } - trimright { - set tl_right 1 - } - default { - set known_lineopts [list trimline trimleft trimright] - error "linelist: unknown -line option value: $lo known values: $known_lineopts" - } - } - } - #normalize trimleft trimright combo - if {$tl_left && $tl_right} { - set opt_line [list "trimline"] - set tl_both 1 - } - # -- --- --- --- --- --- - set opt_commandprefix [tcl::dict::get $opts -commandprefix] - # -- --- --- --- --- --- - set opt_ansiresets [tcl::dict::get $opts -ansiresets] - # -- --- --- --- --- --- - set opt_ansireplays [tcl::dict::get $opts -ansireplays] - if {$opt_ansireplays} { - if {$opt_ansiresets eq "auto"} { - set opt_ansiresets 1 - } - } else { - if {$opt_ansiresets eq "auto"} { - set opt_ansiresets 0 - } - } - # -- --- --- --- --- --- - set linelist [list] - set nlsplit [split $text \n] - if {![llength $opt_line]} { - set linelist $nlsplit - #lappend linelist {*}$nlsplit - } else { - #already normalized trimleft+trimright to trimline - if {$tl_both} { - foreach ln $nlsplit { - lappend linelist [string trim $ln] - } - } elseif {$tl_left} { - foreach ln $nlsplit { - lappend linelist [string trimleft $ln] - } - } elseif {$tl_right} { - foreach ln $nlsplit { - 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] - } - - #review - we need to make sure ansiresets don't accumulate/grow on any line - #Each resulting line should have a reset of some type at start and a pure-reset at end to stop - #see if we can find an ST sequence that most terminals will not display for marking sections? - if {$opt_ansireplays} { - #package require punk::ansi - - if {$opt_ansiresets} { - set RST "\x1b\[0m" - } else { - set RST "" - } - set replaycodes $RST ;#todo - default? - set transformed [list] - #shortcircuit common case of no ansi - #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. - #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) - #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable - #detect_in_list will check at first level. (not intended for detecting ansi in deeper structures) - if {![punk::ansi::ta::detect_in_list $linelist]} { - if {$opt_ansiresets} { - foreach ln $linelist { - lappend transformed $RST$ln$RST - } - set linelist $transformed - } - } else { - - #INLINE punk::ansi::codetype::is_sgr_reset - #regexp {\x1b\[0*m$} $code - set re_is_sgr_reset {\x1b\[0*m$} - #INLINE punk::ansi::codetype::is_sgr - #regexp {\033\[[0-9;:]*m$} $code - set re_is_sgr {\x1b\[[0-9;:]*m$} - - foreach ln $linelist { - #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable - - set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. - if {[llength $ansisplits]<= 1} { - #plaintext only - no ansi codes in line - lappend transformed [string cat $replaycodes $ln $RST] - #leave replaycodes as is for next line - set nextreplay $replaycodes - } else { - set tail $RST - set lastcode [lindex $ansisplits end-1] ;#may or may not be SGR - if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { - if {[lindex $ansisplits end] eq ""} { - #last plaintext is empty. So the line is already suffixed with a reset - set tail "" - set nextreplay $RST - } else { - #trailing text has been reset within line - but no tail reset present - #we normalize by putting a tail reset on anyway - set tail $RST - set nextreplay $RST - } - } elseif {[lindex $ansisplits end] ne "" && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { - #No tail reset - and no need to examine whole line to determine stack that is in effect - set tail $RST - set nextreplay $lastcode - } else { - #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect - #last codeset doesn't end in a pure-reset - #whether code was at very end or not - add a reset tail - set tail $RST - #determine effective replay for line - set codestack [list start] - foreach {pt code} $ansisplits { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set codestack [list] ;#different from 'start' marked - this means we've had a reset - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set codestack [list $code] - } else { - if {[punk::ansi::codetype::is_sgr $code]} { - #todo - proper test of each code - so we only take latest background/foreground etc. - #requires handling codes with varying numbers of parameters. - #basic simplification - remove straight dupes. - set dup_posns [lsearch -all -exact $codestack $code] ;#!must use -exact as codes have square brackets which are interpreted as glob chars. - set codestack [lremove $codestack {*}$dup_posns] - lappend codestack $code - } ;#else gx0 or other code - we don't want to stack it with SGR codes - } - } - if {$codestack eq [list start]} { - #No SGRs - may have been other codes - set line_has_sgr 0 - } else { - #list is either empty or begins with start - empty means it had SGR reset - so it still invalidates current state of replaycodes - set line_has_sgr 1 - if {[lindex $codestack 0] eq "start"} { - set codestack [lrange $codestack 1 end] - } - } - - #set newreplay [join $codestack ""] - set newreplay [punk::ansi::codetype::sgr_merge_list {*}$codestack] - - if {$line_has_sgr && $newreplay ne $replaycodes} { - #adjust if it doesn't already does a reset at start - if {[punk::ansi::codetype::has_sgr_leadingreset $newreplay]} { - set nextreplay $newreplay - } else { - set nextreplay $RST$newreplay - } - } else { - set nextreplay $replaycodes - } - } - if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { - #no point attaching any replay - lappend transformed [string cat $ln $tail] - } else { - lappend transformed [string cat $replaycodes $ln $tail] - } - } - set replaycodes $nextreplay - } - set linelist $transformed - } - } - - if {[llength $opt_commandprefix]} { - set transformed [list] - foreach ln $linelist { - lappend transformed [{*}$opt_commandprefix $ln] - } - set linelist $transformed - } - - return $linelist - } - if {$has_punk_ansi} { - #optimise linelist as much as possible - set linelist_body [string map { ""} $linelist_body] - } else { - #punk ansi not avail at time of package load. - #by putting in calls to punk::ansi the user will get appropriate error messages - set linelist_body [string map { "package require punk::ansi"} $linelist_body] - } - proc linelist {args} $linelist_body - - - interp alias {} errortime {} punk::lib::errortime - proc errortime {script groupsize {iters 2}} { - #by use MAK from https://wiki.tcl-lang.org/page/How+to+Measure+Performance - set i 0 - set times {} - if {$iters < 2} {set iters 2} - - for {set i 0} {$i < $iters} {incr i} { - set result [uplevel [list time $script $groupsize]] - lappend times [lindex $result 0] - } - - set average 0.0 - set s2 0.0 - - foreach time $times { - set average [expr {$average + double($time)/$iters}] - } - - foreach time $times { - set s2 [expr {$s2 + (($time-$average)*($time-$average) / ($iters-1))}] - } - - set sigma [expr {int(sqrt($s2))}] - set average [expr {int($average)}] - - return "$average +/- $sigma microseconds per iteration" - } - - #test function to use with show_jump_tables - #todo - check if switch compilation to jump tables differs by Tcl version - proc switch_char_test {c} { - set dec [scan $c %c] - foreach t [list 1 2 3] { - switch -- $c { - x { - return [list $dec x $t] - } - y { - return [list $dec y $t] - } - z { - return [list $dec z $t] - } - } - } - - #tcl 8.6/8.7 (at least) - #curlies must be unescaped and unbraced to work as literals in switch and enable it to compile to jumpTable - switch -- $c { - a { - return [list $dec a] - } - {"} { - return [list $dec dquote] - } - {[} {return [list $dec lb]} - {]} {return [list $dec rb]} - "{" { - return [list $dec lbrace] - } - "}" { - return [list $dec rbrace] - } - default { - return [list $dec $c] - } - } - - - - } - - #we are interested in seeing jumpTable line and following lines up until next line starting with "Command" or bracketed number e.g (164) - proc show_jump_tables {args} { - #avoiding use of 'info cmdtype' as unavaliable in safe interps as at 2024-06. - if {[llength $args] == 1} { - set data [tcl::unsupported::disassemble proc [lindex $args 0]] - } elseif {[llength $args] == 2} { - #review - this looks for direct methods on the supplied object/class, and then tries to disassemble method on the supplied class or class of supplied object if it isn't a class itself. - #not sure if this handles more complex hierarchies or mixins etc. - lassign $args obj method - if {![info object isa object $obj]} { - error "show_jump_tables unable to examine '$args'. $obj is not an oo object" - } - #classes are objects too and can have direct methods - if {$method in [info object methods $obj]} { - set data [tcl::unsupported::disassemble objmethod $obj $method] - } else { - if {![info object isa class $obj]} { - set obj [info object class $obj] - } - set data [tcl::unsupported::disassemble method $obj $method] - } - } else { - error "show_jump_tables expected a procname or a class/object and method" - } - set result "" - set in_jt 0 - foreach ln [split $data \n] { - set tln [string trim $ln] - if {!$in_jt} { - if {[string match *jumpTable* $ln]} { - append result $ln \n - set in_jt 1 - } - } else { - if {[string match Command* $tln] || [string match "(*) *" $tln]} { - set in_jt 0 - } else { - append result $ln \n - } - } - } - return $result - } - - proc temperature_f_to_c {deg_fahrenheit} { - return [expr {($deg_fahrenheit -32) * (5/9.0)}] - } - proc temperature_c_to_f {deg_celsius} { - return [expr {($deg_celsius * (9/5.0)) + 32}] - } - - proc interp_sync_package_paths {interp} { - if {![interp exists $interp]} { - error "interp_sync_package_paths error. interp '$interp' not found. Create it first with \[interp create $interp\]" - } - interp eval $interp [list set ::auto_path $::auto_path] - interp eval $interp {tcl::tm::remove {*}[tcl::tm::list]} - interp eval $interp [list tcl::tm::add {*}[lreverse [tcl::tm::list]]] - } - - proc objclone {obj} { - append obj2 $obj {} - } - proc set_clone {varname obj} { - #used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_clone varnmame $val] - append obj2 $obj {} - uplevel 1 [list set $varname $obj2] - } - - - - proc format_number {numbers_or_commaformattednumbers {delim ""} {groupsize ""}} { - variable has_twapi - if {$has_twapi} { - if {$delim eq "" && $groupsize eq ""} { - set localeid [twapi::get_system_default_lcid] - } - } - #when using twapi we currently only get the localeid - not the specific defaults - #when not using twapi, or on non-windows platforms - we don't currently have a mechanism to look up user preferences for this - set default_delim "," - set default_groupsize 3 - - set results [list] - set nums [objclone $numbers_or_commaformattednumbers] ;#stops single num from getting internal rep of list - foreach inputnum $nums { - set number [objclone $inputnum] - #also handle tcl 8.7+ underscores in numbers - set number [string map [list _ "" , ""] $number] - #normalize e.g 2e4 -> 20000.0 - set number [expr {$number}] - - if {$has_twapi} { - if {$delim eq "" && $groupsize eq ""} { - lappend results [twapi::format_number $number $localeid -idigits -1] - continue - } else { - #setting just one of delim or groupsize means we don't get the user's localeid based default for the non-set one - #todo - document it? Find a way to lookup localeid based defaults whenever either is unspecified? - if {$delim eq ""} {set delim $default_delim} - if {$groupsize eq ""} {set groupsize $default_groupsize} - lappend results [twapi::format_number $number 0 -idigits -1 -sthousand $delim -sgrouping $groupsize] - continue - } - } - #todo - get configured user defaults - if {$delim eq ""} { - set delim $default_delim - } - if {$groupsize eq ""} { - set groupsize $default_groupsize - } - - lappend results [delimit_number $number $delim $groupsize] - } - - if {[llength $results] == 1} { - #keep intrep as string rather than list - return [lindex $results 0] - } - return $results - } - - - #from wiki https://wiki.tcl-lang.org/page/Delimiting+Numberse - # Given a number represented as a string, insert delimiters to break it up for - # readability. Normally, the delimiter will be a comma which will be inserted every - # three digits. However, the delimiter and groupsize are optional arguments, - # permitting use in other locales. - # - # The string is assumed to consist of digits, possibly preceded by spaces, - # and possibly containing a decimal point, i.e.: [:space:]*[:digit:]*\.[:digit:]* - - proc delimit_number {unformattednumber {delim ","} {GroupSize 3}} { - set number [objclone $unformattednumber] - set number [string map {_ ""} $number] - #normalize using expr - e.g 2e4 -> 20000.0 - set number [expr {$number}] - # First, extract right hand part of number, up to and including decimal point - set point [string last "." $number]; - if {$point >= 0} { - set PostDecimal [string range $number $point+1 end]; - set PostDecimalP 1; - } else { - set point [expr {[string length $number] + 1}] - set PostDecimal ""; - set PostDecimalP 0; - } - - # Now extract any leading spaces. review - regex for whitespace instead of just ascii space? - set ind 0; - while {[string equal [string index $number $ind] \u0020]} { - incr ind; - } - set FirstNonSpace $ind; - set LastSpace [expr {$FirstNonSpace - 1}]; - set LeadingSpaces [string range $number 0 $LastSpace]; - - # Now extract the non-fractional part of the number, omitting leading spaces. - set MainNumber [string range $number $FirstNonSpace $point-1]; - - # Insert commas into the non-fractional part. - set Length [string length $MainNumber]; - set Phase [expr {$Length % $GroupSize}] - set PhaseMinusOne [expr {$Phase -1}]; - set DelimitedMain ""; - - #First we deal with the extra stuff. - if {$Phase > 0} { - append DelimitedMain [string range $MainNumber 0 $PhaseMinusOne]; - } - set FirstInGroup $Phase; - set LastInGroup [expr {$FirstInGroup + $GroupSize -1}]; - while {$LastInGroup < $Length} { - if {$FirstInGroup > 0} { - append DelimitedMain $delim; - } - append DelimitedMain [string range $MainNumber $FirstInGroup $LastInGroup]; - incr FirstInGroup $GroupSize - incr LastInGroup $GroupSize - } - - # Reassemble the number. - if {$PostDecimalP} { - return [format "%s%s.%s" $LeadingSpaces $DelimitedMain $PostDecimal]; - } else { - return [format "%s%s" $LeadingSpaces $DelimitedMain]; - } - } - - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::lib ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -tcl::namespace::eval punk::lib::flatgrid { - namespace export filler_count rows cols col row block - - #WARNING - requires lseq and 'lsearch -stride' - #WARNING - lsearch -stride oddity with empty strings https://core.tcl-lang.org/tcl/tktview/edebb6a4 - #todo - 8.6 fallback? - - proc filler_count {listlen numcolumns} { - #if {$numcolumns <= 0} {error "filler_count requires 1 or more numcolumns"} ;#or allow divide by zero error - #if {$listlen == 0} {return $numcolumns} ;#an option - but returning zero might make more sense - expr {($numcolumns - ($listlen % $numcolumns)) % $numcolumns} - } - proc rows {list numcolumns {blank NULL}} { - set numblanks [filler_count [llength $list] $numcolumns] - set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] - set splits [lseq 0 to [llength $padded_list] by $numcolumns] - set rows [list] - set i 1 - foreach s [lrange $splits 0 end-1] { - lappend rows [lrange $padded_list $s [lindex $splits $i]-1] - incr i - } - return $rows - } - proc cols {list numcolumns {blank NULL}} { - set cols [list] - foreach colindex [lseq 0 $numcolumns-1] { - lappend cols [lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] *] - } - return $cols - } - proc cols2 {list numcolumns {blank NULL}} { - set cols [list] - foreach colindex [lseq 0 $numcolumns-1] { - lappend cols [col2 $list $numcolumns $colindex $blank] - } - return $cols - } - proc col {list numcolumns colindex {blank NULL}} { - lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] * - } - proc col2 {list numcolumns colindex {blank NULL}} { - set numblanks [filler_count [llength $list] $numcolumns] - set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] - set splits [lseq 0 to [llength $padded_list] by $numcolumns] - set col [list] - foreach s [lrange $splits 0 end-1] { - lappend col [lindex $padded_list $s+$colindex] - } - return $col - } - proc col3 {list numcolumns colindex {blank NULL}} { - set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] - lmap s [lrange [lseq 0 to [llength $padded_list] by $numcolumns] 0 end-1] {lindex $padded_list $s+$colindex} - } - proc col4 {list numcolumns colindex {blank NULL}} { - #slow - set vars [lrepeat $numcolumns _] - lset vars $colindex v - if {$blank eq ""} { - return [lmap $vars $list {set v}] - } - set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] - lmap $vars [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] {set v} - } - - proc block {list numcolumns {blank NULL}} { - set colblocks [list] - foreach c [cols $list $numcolumns $blank] { - lappend colblocks [join $c \n] " " - } - textblock::join -- {*}$colblocks - } - proc block2 {list numcolumns {blank NULL}} { - set colblocks [list] - foreach c [cols2 $list $numcolumns $blank] { - lappend colblocks [join $c \n] " " - } - textblock::join -- {*}$colblocks - } -} - -tcl::namespace::eval punk::lib::test { - - - -} - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#todo - way to generate 'internal' docs separately? -#*** !doctools -#[section Internal] -tcl::namespace::eval punk::lib::system { - #*** !doctools - #[subsection {Namespace punk::lib::system}] - #[para] Internal functions that are not part of the API - #[list_begin definitions] - - - proc mostFactorsBelow {n} { - ##*** !doctools - #[call [fun mostFactorsBelow] [arg n]] - #[para]Find the number below $n which has the greatest number of factors - #[para]This will get slow quickly as n increases (100K = 1s+ 2024) - set most 0 - set mostcount 0 - for {set i 1} {$i < $n} {incr i} { - set fc [llength [punk::lib::factors $i]] - if {$fc > $mostcount} { - set most $i - set mostcount $fc - } - } - return [list number $most numfactors $mostcount] - } - proc factorCountBelow_punk {n} { - ##*** !doctools - #[call [fun factorCountBelow] [arg n]] - #[para]For numbers 1 to n - keep a tally of the total count of factors - #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result - #[para]and as a rudimentary performance comparison - #[para]gets slow quickly! - set tally 0 - for {set i 1} {$i <= $n} {incr i} { - incr tally [llength [punk::lib::factors $i]] - } - return $tally - } - proc factorCountBelow_numtheory {n} { - ##*** !doctools - #[call [fun factorCountBelow] [arg n]] - #[para]For numbers 1 to n - keep a tally of the total count of factors - #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result - #[para]and as a rudimentary performance comparison - #[para]gets slow quickly! (significantly slower than factorCountBelow_punk) - package require math::numtheory - set tally 0 - for {set i 1} {$i <= $n} {incr i} { - incr tally [llength [math::numtheory::factors $i]] - } - return $tally - } - - proc factors2 {x} { - ##*** !doctools - #[call [fun factors2] [arg x]] - #[para]Return a sorted list of factors of x - #[para]A similar brute-force mechanism to factors - but keeps result ordering as we go. - set smallfactors [list 1] - set j 2 - set max [expr {sqrt($x)}] - while {$j < $max} { - if {($x % $j) == 0} { - lappend smallfactors $j - lappend largefactors [expr {$x / $j}] - } - incr j - } - #handle sqrt outside loop so we don't have to sort/dedup or check list membership in main loop - if {($x % $j) == 0} { - if {$j == ($x / $j)} { - lappend smallfactors $j - } - } - return [concat $smallfactors [lreverse $largefactors] $x] - } - - - - # incomplete - report which is the innermost bracket/quote etc awaiting completion for a Tcl command - #important - used by punk::repl - proc incomplete {partial} { - #we can apparently get away without concatenating current innerpartial to previous in list - REVIEW. - if {[info complete $partial]} { - return [list] - } - set clist [split $partial ""] - #puts stderr "-->$clist<--" - set waiting [list ""] - set innerpartials [list ""] - set escaped 0 - set i 0 - foreach c $clist { - if {$c eq "\\"} { - set escaped [expr {!$escaped}] - incr i - continue - } ;# set escaped 0 at end - set p [lindex $innerpartials end] - if {$escaped == 0} { - #NOTE - curly braces as switch arm keys must be unescaped and balanced. (escapes stop byte-compilation to jumpTable for switch statements for tcl8.6/8.7 at least) - switch -- $c { - {"} { - if {![info complete ${p}]} { - lappend waiting {"} - lappend innerpartials "" - } else { - if {[lindex $waiting end] eq {"}} { - #this quote is endquote - set waiting [lrange $waiting 0 end-1] - set innerpartials [lrange $innerpartials 0 end-1] - } else { - if {![info complete ${p}$c]} { - lappend waiting {"} - lappend innerpartials "" - } else { - set p ${p}${c} - lset innerpartials end $p - } - } - } - } - {[} { - if {![info complete ${p}$c]} { - lappend waiting "\]" - lappend innerpartials "" - } else { - set p ${p}${c} - lset innerpartials end $p - } - } - "{" { - if {![info complete ${p}$c]} { - lappend waiting "\}" - lappend innerpartials "" - } else { - set p ${p}${c} - lset innerpartials end $p - } - } - "}" - - default { - set waitingfor [lindex $waiting end] - if {$c eq "$waitingfor"} { - set waiting [lrange $waiting 0 end-1] - set innerpartials [lrange $innerpartials 0 end-1] - } else { - set p ${p}${c} - lset innerpartials end $p - } - } - } - } else { - set p ${p}${c} - lset innerpartials end $p - } - set escaped 0 - incr i - } - set incomplete [list] - foreach w $waiting { - #to be treated as literals - curly braces must be unescaped here - and balanced - hence the left-curly empty arm. - switch -- $w { - {"} { - lappend incomplete $w - } - {]} { - lappend incomplete "\[" - } - "{" {} - "}" { - lappend incomplete "\{" - } - } - } - set debug 0 - if {$debug} { - foreach w $waiting p $innerpartials { - puts stderr "->awaiting:'$w' partial: $p" - } - } - return $incomplete - } - #This only works for very simple cases will get confused with for example: - # {set x "a["""} - proc incomplete_naive {partial} { - if {[info complete $partial]} { - return [list] - } - set clist [split $partial ""] - set waiting [list] - set escaped 0 - foreach c $clist { - if {$c eq "\\"} { - set escaped [expr {!$escaped}] - continue - } - if {!$escaped} { - if {$c eq {"}} { - if {[lindex $waiting end] eq {"}} { - set waiting [lrange $waiting 0 end-1] - } else { - lappend waiting {"} - } - } elseif {$c eq "\["} { - lappend waiting "\]" - } elseif {$c eq "\{"} { - lappend waiting "\}" - } else { - set waitingfor [lindex $waiting end] - if {$c eq "$waitingfor"} { - set waiting [lrange $waiting 0 end-1] - } - } - } - } - set incomplete [list] - foreach w $waiting { - if {$w eq {"}} { - lappend incomplete $w - } elseif {$w eq "\]"} { - lappend incomplete "\[" - } elseif {$w eq "\}"} { - lappend incomplete "\{" - } - } - return $incomplete - } - - #get info about punk nestindex key ie type: list,dict,undetermined - # pdict devel - 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 - } - - #??? - - } - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::lib::system ---}] -} - -tcl::namespace::eval punk::lib::debug { - proc showdict {args} {} -} - -namespace eval ::punk::args::register { - #use fully qualified so 8.6 doesn't find existing var in global namespace - lappend ::punk::args::register::NAMESPACES ::punk::lib -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::lib [tcl::namespace::eval punk::lib { - variable pkg punk::lib - variable version - set version 0.1.1 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm index 17c9918b..ad60b069 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm @@ -507,6 +507,7 @@ namespace eval punk::mix::cli { -punkcheck_eventobj "\uFFFF"\ -glob *.tm\ -podglob #modpod-*\ + -tarjarglob #tarjar-*\ ] set opts [dict merge $defaults $args] @@ -519,6 +520,7 @@ namespace eval punk::mix::cli { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set fileglob [dict get $opts -glob] set podglob [dict get $opts -podglob] + set tarjarglob [dict get $opts -tarjarglob] if {![string match "*.tm" $fileglob]} { error "build_modules_from_source_to_base -glob '$fileglob' doesn't seem to target tcl modules." } @@ -580,6 +582,10 @@ namespace eval punk::mix::cli { foreach podpath $src_pods { dict set process_modules $podpath [dict create -type pod] } + set src_tarjars [glob -nocomplain -dir $current_source_dir -type d -tail $tarjarglob] + foreach tarjarpath $src_tarjars { + dict set process_modules $tarjarpath [dict create -type tarjar] + } 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] @@ -801,8 +807,173 @@ namespace eval punk::mix::cli { } } tarjar { + #maint - overall code structure same as pod - refactor? #basename may still contain #tarjar- #to be obsoleted - update modpod to (optionally) use vfs::tar ? + if {[string match #tarjar-* $basename]} { + set basename [string range $basename 8 end] + } else { + error "build_modules_from_source_to_base, tarjar, unexpected basename $basename" ;#shouldn't be possible with default tarjarglob - review - why is tarjarglob 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\ + ] + set had_error 0 + + # -max_depth -1 for no limit + set build_installername tarjars_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/#tarjar-$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/#tarjar-$basename-$module_build_version/#tarjar-loadscript-$basename.tcl + #we don't need to modify version or name of the loadscript + #just do basic sanity check that the file exists + if {![file exists $tmfile]} { + set had_error 1 + lappend notes "tarjar_loadscript_missing" + } + } + #delete and regenerate .tm + set notes [list] + if {[catch { + file delete $buildfolder/$basename-$module_build_version.tm + } err]} { + set had_error 1 + lappend notes "tm_delete_failed" + } + #create ordinary tar file without using external executable + package require tar ;#tcllib + set tarfile $buildfolder/$basename-$module_build_version.tm ;#ordinary tar file (no compression - store) + set wd [pwd] + cd $buildfolder + puts "tar::create $tarfile #tarjar-$basename-$module_build_version" + if {[catch { + tar::create $tarfile #tarjar-$basename-$module_build_version + } errMsg]} { + set had_error 1 + puts stderr "tar::create $tarfile failed with msg\n $errMsg" + lappend notes "tar_create_failed" + } + cd $wd + + if {![file exists $tarfile]} { + set had_error 1 + lappend notes "tar_result_missing" + } + + + 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 "T" + 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 + + #JMN - review + if {!$had_error} { + $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 + if {[catch { + file copy -force $modulefile $target_module_dir + } errMsg]} { + puts stderr "FAILED to copy tarjar module $modulefile to $target_module_dir" + $event targetset_end FAILED -note "could not copy $modulefile" + } else { + puts stderr "Copied tarjar module $modulefile to $target_module_dir" + # -- --- --- --- --- --- + $event targetset_end OK -note "tarjar" + } + } else { + puts -nonewline stderr "t" + set did_skip 1 + if {$is_interesting} { + puts stderr "$modulefile [$event targetset_source_changes]" + } + $event targetset_end SKIPPED + } + } } file { @@ -829,39 +1000,40 @@ namespace eval punk::mix::cli { if {[file exists $current_source_dir/#tarjar-$basename-$magicversion]} { - #rebuild the .tm from the #tarjar + #rebuilding the .tm from the #tarjar already handled above + puts -nonewline stderr "-" - if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} { + #if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} { - } else { + #} else { - } - #REVIEW - should be in same structure/depth as $target_module_dir in _build? + #} + ##REVIEW - should be in same structure/depth as $target_module_dir in _build? - #TODO - set buildfolder $current_sourcedir/_build - file mkdir $buildfolder + ##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 + #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 + #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 + #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}#]} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm index e899a401..3de09e5e 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -73,7 +73,7 @@ tcl::namespace::eval punk::ns { set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $ns_current *]] } else { set is_absolute [string match ::* $ns_or_glob] - set has_globchars [regexp {[*?]} $ns_or_glob] + set has_globchars [regexp {[*?]} $ns_or_glob] ;#basic globs only? if {$is_absolute} { if {!$has_globchars} { if {![nsexists $ns_or_glob]} { @@ -747,7 +747,13 @@ tcl::namespace::eval punk::ns { return $nslist } - variable usageinfo_char \U1f6c8 + #The information symbol - usually i in a circle + #punkargs " symbol \U1f6c8" ;#problematic on terminals that lie about cursor position after emitting this character + #The older \u2139 could be used - but it is sometimes a boxed i, sometimes a bold stylized i, sometimes a pre-coloured boxed i + #\u24d8 (circled latein small letter i) seems more consistent and can have our own colour applied. + #variable usageinfo_char \U1f6c8 + variable usageinfo_char \u24d8 + # command has usageinfo e.g from punk::args. todo cmdline, argp, tepam etc? proc Usageinfo_mark {{ansicodes \UFFEF}} { variable usageinfo_char @@ -760,6 +766,7 @@ tcl::namespace::eval punk::ns { } } + punk::args::define { @id -id ::punk::ns::Cmark @cmd -name punk::ns::Cmark @@ -768,7 +775,7 @@ tcl::namespace::eval punk::ns { oo " symbol \u25c6" ooc " symbol \u25c7" ooo " symbol \u25c8" - punkargs " symbol \U1f6c8" + punkargs " symbol \u24d8" ensemble " symbol \u24ba" native " symbol \u24c3" unknown " symbol \u2370" @@ -797,7 +804,7 @@ tcl::namespace::eval punk::ns { return; #should be unreachable - parse should raise usage error } } - set marks [dict create oo \u25c6 ooc \u25c7 ooo \u25c8 punkargs \U1f6c8 ensemble \u24ba native \u24c3 unknown \U2370] + set marks [dict create oo \u25c6 ooc \u25c7 ooo \u25c8 punkargs \u24d8 ensemble \u24ba native \u24c3 unknown \U2370] if {[llength $ansinames]} { return "[punk::ansi::a+ {*}$ansinames][dict get $marks $type]\x1b\[0m" } else { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm index 11cd9706..7d93d529 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm @@ -1876,7 +1876,9 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #ctrl-c if {$chunk eq "\x03"} { #::punk::repl::handler_console_control "ctrl-c_via_rawloop" - error "character 03 -> ctrl-c" + puts stderr "ctrl-c via rawloop - not signal" + ::punk::repl::handler_console_control ctrl-c via_rawloop + #error "character 03 -> ctrl-c" } if {$chunk eq "\x7f"} { @@ -1898,8 +1900,9 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #for now - exit with small delay for tidyup #ctrl-z #::punk::repl::handler_console_control "ctrl-z_via_rawloop" - if {[catch {mode line}]} { - interp eval code {mode line} + if {[catch {punk::console::mode line}]} { + #REVIEW + interp eval code {punk::console::mode line} } after 1000 {exit 43} return diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm index 2ab1fb01..5d2a2725 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -92,6 +92,9 @@ namespace eval punk::repo { } lappend maincommands {*}$ln } + #fossil output was ordered in columns, but we loaded list in row-wise, messing up the order + set maincommands [lsort $maincommands] + set allcmds [lsort $allcmds] set othercmds [punk::lib::ldiff $allcmds $maincommands] set result "@leaders -min 0\n" diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm deleted file mode 100644 index 73ea752c..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm +++ /dev/null @@ -1,3209 +0,0 @@ -#copyright 2023 Julian Marcel Noble -#license: BSD (revised 3-clause) -# -#Note shellfilter is currently only directly useful for unidirectional channels e.g stdin,stderr,stdout, or for example fifo2 where only one direction is being used. -#To generalize this to bidrectional channels would require shifting around read & write methods on transform objects in a very complicated manner. -#e.g each transform would probably be a generic transform container which holds sub-objects to which read & write are indirected. -#This is left as a future exercise...possibly it's best left as a concept for uni-directional channels anyway -# - as presumably the reads/writes from a bidirectional channel could be diverted off to unidirectional pipelines for processing with less work -# (and maybe even better speed/efficiency if the data volume is asymmetrical and there is significant processing on one direction) -# - - -tcl::namespace::eval shellfilter::log { - variable allow_adhoc_tags 1 - variable open_logs [tcl::dict::create] - variable is_enabled 0 - - proc disable {} { - variable is_enabled - set is_enabled 0 - proc ::shellfilter::log::open {tag settingsdict} {} - proc ::shellfilter::log::write {tag msg} {} - proc ::shellfilter::log::write_sync {tag msg} {} - proc ::shellfilter::log::close {tag} {} - } - - proc enable {} { - variable is_enabled - set is_enabled 1 - #'tag' is an identifier for the log source. - # each tag will use it's own thread to write to the configured log target - proc ::shellfilter::log::open {tag {settingsdict {}}} { - upvar ::shellfilter::sources sourcelist - if {![dict exists $settingsdict -tag]} { - tcl::dict::set settingsdict -tag $tag - } else { - #review - if {$tag ne [tcl::dict::get $settingsdict -tag]} { - error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[tcl::dict::get $settingsdict -tag]' omit -tag, or supply same value" - } - } - if {$tag ni $sourcelist} { - lappend sourcelist $tag - } - - #note new_worker - set worker_tid [shellthread::manager::new_worker $tag $settingsdict] - #puts stderr "shellfilter::log::open this_threadid: [thread::id] tag: $tag worker_tid: $worker_tid" - return $worker_tid - } - proc ::shellfilter::log::write {tag msg} { - upvar ::shellfilter::sources sourcelist - variable allow_adhoc_tags - if {!$allow_adhoc_tags} { - if {$tag ni $sourcelist} { - error "shellfilter::log::write tag '$tag' hasn't been initialised with a call to shellfilter::log::open $tag , and allow_adhoc_tags has been set false. use shellfilter::log::require_open false to allow adhoc tags" - } - } - shellthread::manager::write_log $tag $msg - } - #write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written - proc ::shellfilter::log::write_sync {tag msg} { - shellthread::manager::write_log $tag $msg -async 0 - } - proc ::shellfilter::log::close {tag} { - #shellthread::manager::close_worker $tag - shellthread::manager::unsubscribe [list $tag]; #workertid will be added back to free list if no tags remain subscribed - } - - } - - #review - #configure whether we can call shellfilter::log::write without having called open first - proc require_open {{is_open_required {}}} { - variable allow_adhoc_tags - if {![string length $is_open_required]} { - return $allow_adhoc_tags - } else { - set truevalues [list y yes true 1] - set falsevalues [list n no false 0] - if {[string tolower $is_open_required] in $truevalues} { - set allow_adhoc_tags 1 - } elseif {[string tolower $is_open_required] in $falsevalues} { - set allow_adhoc_tags 0 - } else { - error "shellfilter::log::require_open unrecognised value '$is_open_required' try one of $truevalues or $falsevalues" - } - } - } - if {[catch {package require shellthread}]} { - shellfilter::log::disable - } else { - shellfilter::log::enable - } - -} -namespace eval shellfilter::pipe { - #write channel for program. workerthread reads other end of fifo2 and writes data somewhere - proc open_out {tag_pipename {pipesettingsdict {}}} { - set defaultsettings {-buffering full} - set settingsdict [dict merge $defaultsettings $pipesettingsdict] - package require shellthread - #we are only using the fifo in a single direction to pipe to another thread - # - so whilst wchan and rchan could theoretically each be both read & write we're only using them for one operation each - if {![catch {package require Memchan}]} { - lassign [fifo2] wchan rchan - } else { - package require tcl::chan::fifo2 - lassign [tcl::chan::fifo2] wchan rchan - } - #default -translation for both types of fifo on windows is {auto crlf} - # -encoding is as per '[encoding system]' on the platform - e.g utf-8 (e.g windows when beta-utf8 enabled) - chan configure $wchan -buffering [dict get $settingsdict -buffering] ;# - #application end must not be binary for our filters to operate on it - - - #chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation binary ;#works reasonably.. - chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation lf - - set worker_tid [shellthread::manager::new_pipe_worker $tag_pipename $settingsdict] - #puts stderr "worker_tid: $worker_tid" - - #set_read_pipe does the thread::transfer of the rchan end. -buffering setting is maintained during thread transfer - shellthread::manager::set_pipe_read_from_client $tag_pipename $worker_tid $rchan - - set pipeinfo [list localchan $wchan remotechan $rchan workertid $worker_tid direction out] - return $pipeinfo - } - - #read channel for program. workerthread writes to other end of fifo2 from whereever it's reading (stdin, file?) - proc open_in {tag_pipename {settingsdict {} }} { - package require shellthread - package require tcl::chan::fifo2 - lassign [tcl::chan::fifo2] wchan rchan - set program_chan $rchan - set worker_chan $wchan - chan configure $worker_chan -buffering [dict get $settingsdict -buffering] - chan configure $program_chan -buffering [dict get $settingsdict -buffering] - - chan configure $program_chan -blocking 0 - chan configure $worker_chan -blocking 0 - set worker_tid [shellthread::manager::new_worker $tag_pipename $settingsdict] - - shellthread::manager::set_pipe_write_to_client $tag_pipename $worker_tid $worker_chan - - set pipeinfo [list localchan $program_chan remotechan $worker_chan workertid $worker_tid direction in] - puts stderr "|jn>pipe::open_in returning $pipeinfo" - puts stderr "program_chan: [chan conf $program_chan]" - return $pipeinfo - } - -} - - - -namespace eval shellfilter::ansi { - #maint warning - - #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 - dict set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals - #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] - - #self-contained 2 byte ansi escape sequences - review more? - set 2bytecodes_dict [dict create\ - "reset_terminal" "\033c"\ - "save_cursor_posn" "\u001b7"\ - "restore_cursor_posn" "\u001b8"\ - "cursor_up_one" "\u001bM"\ - ] - set 2bytecodes [dict values $2bytecodes_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 ""] - } - -} -namespace eval shellfilter::chan { - set testobj ::shellfilter::chan::var - if {$testobj ni [info commands $testobj]} { - - oo::class create var { - variable o_datavar - variable o_trecord - variable o_enc - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - set settingsdict [dict get $tf -settings] - set varname [dict get $settingsdict -varname] - set o_datavar $varname - if {[dict exists $tf -junction]} { - set o_is_junction [dict get $tf -junction] - } else { - set o_is_junction 1 ;# as a var is diversionary - default it to be a jucntion - } - } - method initialize {ch mode} { - return [list initialize finalize write] - } - method finalize {ch} { - my destroy - } - method watch {ch events} { - # must be present but we ignore it because we do not - # post any events - } - #method read {ch count} { - # return ? - #} - method write {ch bytes} { - set stringdata [encoding convertfrom $o_enc $bytes] - append $o_datavar $stringdata - return "" - } - method meta_is_redirection {} { - return $o_is_junction - } - method meta_buffering_supported {} { - return [list line full none] - } - } - - #todo - something similar for multiple grep specs each with own -pre & -post .. store to dict? - oo::class create tee_grep_to_var { - variable o_datavar - variable o_lastxlines - variable o_trecord - variable o_grepfor - variable o_prelines - variable o_postlines - variable o_postcountdown - variable o_enc - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [tcl::dict::get $tf -encoding] - set o_lastxlines [list] - set o_postcountdown 0 - set defaults [tcl::dict::create -pre 1 -post 1] - set settingsdict [tcl::dict::get $tf -settings] - set settings [tcl::dict::merge $defaults $settingsdict] - set o_datavar [tcl::dict::get $settings -varname] - set o_grepfor [tcl::dict::get $settings -grep] - set o_prelines [tcl::dict::get $settings -pre] - set o_postlines [tcl::dict::get $settings -post] - if {[tcl::dict::exists $tf -junction]} { - set o_is_junction [tcl::dict::get $tf -junction] - } else { - set o_is_junction 0 - } - } - method initialize {transform_handle mode} { - return [list initialize finalize write] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - #method read {transform_handle count} { - # return ? - #} - method write {transform_handle bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] - set lastx $o_lastxlines - lappend o_lastxlines $logdata - - if {$o_postcountdown > 0} { - append $o_datavar $logdata - if {[regexp $o_grepfor $logdata]} { - #another match in postlines - set o_postcountdown $o_postlines - } else { - incr o_postcountdown -1 - } - } else { - if {[regexp $o_grepfor $logdata]} { - append $o_datavar [join $lastx] - append $o_datavar $logdata - set o_postcountdown $o_postlines - } - } - - if {[llength $o_lastxlines] > $o_prelines} { - set o_lastxlines [lrange $o_lastxlines 1 end] - } - return $bytes - } - method meta_is_redirection {} { - return $o_is_junction - } - method meta_buffering_supported {} { - return [list line] - } - } - - oo::class create tee_to_var { - variable o_datavars - variable o_trecord - variable o_enc - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [tcl::dict::get $tf -encoding] - set settingsdict [tcl::dict::get $tf -settings] - set varname [tcl::dict::get $settingsdict -varname] - set o_datavars $varname - if {[tcl::dict::exists $tf -junction]} { - set o_is_junction [tcl::dict::get $tf -junction] - } else { - set o_is_junction 0 - } - } - method initialize {ch mode} { - return [list initialize finalize write flush clear] - } - method finalize {ch} { - my destroy - } - method clear {ch} { - return - } - method watch {ch events} { - # must be present but we ignore it because we do not - # post any events - } - #method read {ch count} { - # return ? - #} - method flush {ch} { - return "" - } - method write {ch bytes} { - set stringdata [tcl::encoding::convertfrom $o_enc $bytes] - foreach v $o_datavars { - append $v $stringdata - } - return $bytes - } - method meta_is_redirection {} { - return $o_is_junction - } - } - oo::class create tee_to_pipe { - variable o_logsource - variable o_localchan - variable o_enc - variable o_trecord - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [tcl::dict::get $tf -encoding] - set settingsdict [tcl::dict::get $tf -settings] - if {![dict exists $settingsdict -tag]} { - error "tee_to_pipe constructor settingsdict missing -tag" - } - set o_localchan [tcl::dict::get $settingsdict -pipechan] - set o_logsource [tcl::dict::get $settingsdict -tag] - if {[tcl::dict::exists $tf -junction]} { - set o_is_junction [tcl::dict::get $tf -junction] - } else { - set o_is_junction 0 - } - } - method initialize {transform_handle mode} { - return [list initialize read drain write flush clear finalize] - } - method finalize {transform_handle} { - ::shellfilter::log::close $o_logsource - my destroy - } - method watch {transform_handle events} { - # must be present but we ignore it because we do not - # post any events - } - method clear {transform_handle} { - return - } - method drain {transform_handle} { - return "" - } - method read {transform_handle bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] - #::shellfilter::log::write $o_logsource $logdata - puts -nonewline $o_localchan $logdata - return $bytes - } - method flush {transform_handle} { - return "" - } - method write {transform_handle bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] - #::shellfilter::log::write $o_logsource $logdata - puts -nonewline $o_localchan $logdata - return $bytes - } - #a tee is not a redirection - because data still flows along the main path - method meta_is_redirection {} { - return $o_is_junction - } - - } - oo::class create tee_to_log { - variable o_tid - variable o_logsource - variable o_trecord - variable o_enc - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [tcl::dict::get $tf -encoding] - set settingsdict [tcl::dict::get $tf -settings] - if {![tcl::dict::exists $settingsdict -tag]} { - error "tee_to_log constructor settingsdict missing -tag" - } - set o_logsource [tcl::dict::get $settingsdict -tag] - set o_tid [::shellfilter::log::open $o_logsource $settingsdict] - if {[tcl::dict::exists $tf -junction]} { - set o_is_junction [tcl::dict::get $tf -junction] - } else { - set o_is_junction 0 - } - } - method initialize {ch mode} { - return [list initialize read write finalize] - } - method finalize {ch} { - ::shellfilter::log::close $o_logsource - my destroy - } - method watch {ch events} { - # must be present but we ignore it because we do not - # post any events - } - method read {ch bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] - ::shellfilter::log::write $o_logsource $logdata - return $bytes - } - method write {ch bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] - ::shellfilter::log::write $o_logsource $logdata - return $bytes - } - method meta_is_redirection {} { - return $o_is_junction - } - } - - - oo::class create logonly { - variable o_tid - variable o_logsource - variable o_trecord - variable o_enc - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - set settingsdict [dict get $tf -settings] - if {![dict exists $settingsdict -tag]} { - error "logonly constructor settingsdict missing -tag" - } - set o_logsource [dict get $settingsdict -tag] - set o_tid [::shellfilter::log::open $o_logsource $settingsdict] - } - method initialize {transform_handle mode} { - return [list initialize finalize write] - } - method finalize {transform_handle} { - ::shellfilter::log::close $o_logsource - my destroy - } - method watch {transform_handle events} { - # must be present but we ignore it because we do not - # post any events - } - #method read {transform_handle count} { - # return ? - #} - method write {transform_handle bytes} { - set logdata [encoding convertfrom $o_enc $bytes] - if 0 { - if {"utf-16le" in [encoding names]} { - set logdata [encoding convertfrom utf-16le $bytes] - } else { - set logdata [encoding convertto utf-8 $bytes] - #set logdata [encoding convertfrom unicode $bytes] - #set logdata $bytes - } - } - #set logdata $bytes - #set logdata [string map [list \r -r- \n -n-] $logdata] - #if {[string equal [string range $logdata end-1 end] "\r\n"]} { - # set logdata [string range $logdata 0 end-2] - #} - #::shellfilter::log::write_sync $o_logsource $logdata - ::shellfilter::log::write $o_logsource $logdata - #return $bytes - return - } - method meta_is_redirection {} { - return 1 - } - } - - #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::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 - variable o_enc - variable o_is_junction - constructor {tf} { - package require punk::ansi - set o_trecord $tf - set o_enc [dict get $tf -encoding] - if {[dict exists $tf -junction]} { - set o_is_junction [dict get $tf -junction] - } else { - set o_is_junction 0 - } - } - method initialize {transform_handle mode} { - return [list initialize read write clear flush drain finalize] - } - method finalize {transform_handle} { - my destroy - } - method clear {transform_handle} { - return - } - method watch {transform_handle events} { - } - method drain {transform_handle} { - return "" - } - method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - set outstring [punk::ansi::ansistrip $instring] - return [encoding convertto $o_enc $outstring] - } - method flush {transform_handle} { - return "" - } - method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - set outstring [punk::ansi::ansistrip $instring] - return [encoding convertto $o_enc $outstring] - } - method meta_is_redirection {} { - return $o_is_junction - } - } - - #a test - oo::class create reconvert { - variable o_trecord - variable o_enc - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - } - method initialize {transform_handle mode} { - return [list initialize read write finalize] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - set outstring $instring - - return [encoding convertto $o_enc $outstring] - } - method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - set outstring $instring - - return [encoding convertto $o_enc $outstring] - } - } - oo::define reconvert { - method meta_is_redirection {} { - return 0 - } - } - - - #this isn't a particularly nice thing to do to a stream - especially if someone isn't expecting ansi codes sprinkled through it. - #It can be useful for test/debugging - #Due to chunking at random breaks - we have to check if an ansi code in the underlying stream has been split - otherwise our wrapping will break the existing ansi - # - set sixelstart_re {\x1bP([;0-9]*)q} ;#7-bit - todo 8bit - #todo kitty graphics \x1b_G... - #todo iterm graphics - - oo::class create ansiwrap { - variable o_trecord - variable o_enc - variable o_colour - variable o_do_colour - variable o_do_normal - variable o_is_junction - variable o_codestack - variable o_gx_state ;#on/off alt graphics - variable o_buffered - constructor {tf} { - package require punk::ansi - set o_trecord $tf - set o_enc [tcl::dict::get $tf -encoding] - set settingsdict [tcl::dict::get $tf -settings] - if {[tcl::dict::exists $settingsdict -colour]} { - set o_colour [tcl::dict::get $settingsdict -colour] - set o_do_colour [punk::ansi::a+ {*}$o_colour] - set o_do_normal [punk::ansi::a] - } else { - set o_colour {} - set o_do_colour "" - set o_do_normal "" - } - set o_codestack [list] - set o_gx_state [expr {off}] - set o_buffered "" ;#hold back data that potentially contains partial ansi codes - if {[tcl::dict::exists $tf -junction]} { - set o_is_junction [tcl::dict::get $tf -junction] - } else { - set o_is_junction 0 - } - } - - - #todo - track when in sixel,iterm,kitty graphics data - can be very large - method Trackcodes {chunk} { - #note - caller can use 2 resets in a single unit to temporarily reset to no sgr (override ansiwrap filter) - #e.g [a+ reset reset] (0;0m vs 0;m) - - #puts stdout "===[ansistring VIEW -lf 1 $o_buffered]" - set buf $o_buffered$chunk - set emit "" - if {[string last \x1b $buf] >= 0} { - #detect will detect ansi SGR and gron groff and other codes - if {[punk::ansi::ta::detect $buf]} { - #split_codes_single regex faster than split_codes - but more resulting parts - #'single' refers to number of escapes - but can still contain e.g multiple SGR codes (or mode set operations etc) - set parts [punk::ansi::ta::split_codes_single $buf] - #process all pt/code pairs except for trailing pt - foreach {pt code} [lrange $parts 0 end-1] { - #puts "<==[ansistring VIEW -lf 1 $pt]==>" - switch -- [llength $o_codestack] { - 0 { - append emit $o_do_colour$pt$o_do_normal - } - 1 { - if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { - append emit $o_do_colour$pt$o_do_normal - set o_codestack [list] - } else { - #append emit [lindex $o_codestack 0]$pt - append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$pt - } - } - default { - append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$pt - } - } - #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { - # append emit $o_do_colour$pt$o_do_normal - # #append emit $pt - #} else { - # append emit $pt - #} - - 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] - switch -- $leadernorm { - 7CSI - 8CSI { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set o_codestack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set o_codestack [list $code] - } elseif {[punk::ansi::codetype::is_sgr $code]} { - #todo - make caching is_sgr method - set dup_posns [lsearch -all -exact $o_codestack $code] - set o_codestack [lremove $o_codestack {*}$dup_posns] - lappend o_codestack $code - } else { - - } - } - 7GFX { - switch -- [tcl::string::index $code 2] { - "0" { - set o_gx_state on - } - "B" { - set o_gx_state off - } - } - } - default { - #other ansi codes - } - } - append emit $code - } - - - set trailing_pt [lindex $parts end] - if {[string first \x1b $trailing_pt] >= 0} { - #puts stdout "...[ansistring VIEW -lf 1 $trailing_pt]...buffered:<[ansistring VIEW $o_buffered]> '[ansistring VIEW -lf 1 $emit]'" - #may not be plaintext after all - set o_buffered $trailing_pt - #puts stdout "=-=[ansistring VIEWCODES $o_buffered]" - } else { - #puts [a+ yellow]???[ansistring VIEW "'$o_buffered'<+>'$trailing_pt'"]???[a] - switch -- [llength $o_codestack] { - 0 { - append emit $o_do_colour$trailing_pt$o_do_normal - } - 1 { - if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { - append emit $o_do_colour$trailing_pt$o_do_normal - set o_codestack [list] - } else { - #append emit [lindex $o_codestack 0]$trailing_pt - append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$trailing_pt - } - } - default { - append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$trailing_pt - } - } - #if {![llength $o_codestack] || ([llength $o_codestack] ==1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]])} { - # append emit $o_do_colour$trailing_pt$o_do_normal - #} else { - # append emit $trailing_pt - #} - #the previous o_buffered formed the data we emitted - nothing new to buffer because we emitted all parts including the trailing plaintext - set o_buffered "" - } - - - } else { - #REVIEW - this holding a buffer without emitting as we go is ugly. - # - we may do better to detect and retain the opener, then use that opener to avoid false splits within the sequence. - # - we'd then need to detect the appropriate close to restart splitting and codestacking - # - we may still need to retain and append the data to the opener (in some cases?) - which is a slight memory issue - but at least we would emit everything immediately. - - - #puts "-->esc but no detect" - #no complete ansi codes - but at least one esc is present - if {[string index $buf end] eq "\x1b" && [string first \x1b $buf] == [string length $buf]-1} { - #string index in first part of && clause to avoid some unneeded scans of whole string for this test - #we can't use 'string last' - as we need to know only esc is last char in buf - #puts ">>trailing-esc<<" - set o_buffered \x1b - set emit $o_do_colour[string range $buf 0 end-1]$o_do_normal - #set emit [string range $buf 0 end-1] - set buf "" - } else { - set emit_anyway 0 - #todo - ensure non-ansi escapes in middle of chunks don't lead to ever growing buffer - if {[punk::ansi::ta::detect_st_open $buf]} { - #no detect - but we have an ST open (privacy msg etc) - allow a larger chunk before we give up - could include newlines (and even nested codes - although not widely interpreted that way in terms) - set st_partial_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of unclosed ST code - #todo - configurable ST max - use 1k for now - if {$st_partial_len < 1001} { - append o_buffered $chunk - set emit "" - set buf "" - } else { - set emit_anyway 1 - set o_buffered "" - } - } else { - set possible_code_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of possible code - #most opening sequences are 1,2 or 3 chars - review? - set open_sequence_detected [punk::ansi::ta::detect_open $buf] - if {$possible_code_len > 10 && !$open_sequence_detected} { - set emit_anyway 1 - set o_buffered "" - } else { - #could be composite sequence with params - allow some reasonable max sequence length - #todo - configurable max sequence length - #len 40-50 quite possible for SGR sequence using coloured underlines etc, even without redundancies - # - allow some headroom for redundant codes when the caller didn't merge. - if {$possible_code_len < 101} { - append o_buffered $chunk - set buf "" - set emit "" - } else { - #allow a little more grace if we at least have an opening ansi sequence of any type.. - if {$open_sequence_detected && $possible_code_len < 151} { - append o_buffered $chunk - set buf "" - set emit "" - } else { - set emit_anyway 1 - set o_buffered "" - } - } - } - } - if {$emit_anyway} { - #assert: any time emit_anyway == 1 buf already contains all of previous o_buffered and o_buffered has been cleared. - - #looked ansi-like - but we've given enough length without detecting close.. - #treat as possible plain text with some esc or unrecognised ansi sequence - switch -- [llength $o_codestack] { - 0 { - set emit $o_do_colour$buf$o_do_normal - } - 1 { - if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { - set emit $o_do_colour$buf$o_do_normal - set o_codestack [list] - } else { - #set emit [lindex $o_codestack 0]$buf - set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf - } - } - default { - #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf - set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf - } - } - #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { - # set emit $o_do_colour$buf$o_do_normal - #} else { - # set emit $buf - #} - } - } - } - } else { - #no esc - #puts stdout [a+ yellow]...[a] - #test! - switch -- [llength $o_codestack] { - 0 { - set emit $o_do_colour$buf$o_do_normal - } - 1 { - if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { - set emit $o_do_colour$buf$o_do_normal - set o_codestack [list] - } else { - #set emit [lindex $o_codestack 0]$buf - set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf - } - } - default { - #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf - set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf - } - } - set o_buffered "" - } - return [dict create emit $emit stacksize [llength $o_codestack]] - } - method initialize {transform_handle mode} { - #clear undesirable in terminal output channels (review) - return [list initialize write flush read drain finalize] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - method clear {transform_handle} { - #In the context of stderr/stdout - we probably don't want clear to run. - #Terminals might call it in the middle of a split ansi code - resulting in broken output. - #Leave clear of it the init call - puts stdout "" - set emit [tcl::encoding::convertto $o_enc $o_buffered] - set o_buffered "" - return $emit - } - method flush {transform_handle} { - #puts stdout "" - set emit [tcl::encoding::convertto $o_enc $o_buffered] - set o_buffered "" - return $emit - return - } - method write {transform_handle bytes} { - set instring [tcl::encoding::convertfrom $o_enc $bytes] - set streaminfo [my Trackcodes $instring] - set emit [dict get $streaminfo emit] - - #review - wrapping already done in Trackcodes - #if {[dict get $streaminfo stacksize] == 0} { - # #no ansi on the stack - we can wrap - # #review - # set outstring "$o_do_colour$emit$o_do_normal" - #} else { - #} - #if {[llength $o_codestack]} { - # set outstring [punk::ansi::codetype::sgr_merge_singles $o_codestack]$emit - #} else { - # set outstring $emit - #} - - set outstring $emit - - #puts stdout "decoded >>>[ansistring VIEWCODES $outstring]<<<" - #puts stdout "re-encoded>>>[ansistring VIEW [tcl::encoding::convertto $o_enc $outstring]]<<<" - return [tcl::encoding::convertto $o_enc $outstring] - } - method Write_naive {transform_handle bytes} { - set instring [tcl::encoding::convertfrom $o_enc $bytes] - set outstring "$o_do_colour$instring$o_do_normal" - #set outstring ">>>$instring" - return [tcl::encoding::convertto $o_enc $outstring] - } - method drain {transform_handle} { - return "" - } - method read {transform_handle bytes} { - set instring [tcl::encoding::convertfrom $o_enc $bytes] - set outstring "$o_do_colour$instring$o_do_normal" - return [tcl::encoding::convertto $o_enc $outstring] - } - method meta_is_redirection {} { - return $o_is_junction - } - } - #todo - something - oo::class create rebuffer { - variable o_trecord - variable o_enc - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - } - method initialize {transform_handle mode} { - return [list initialize read write finalize] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - set outstring $instring - - return [encoding convertto $o_enc $outstring] - } - method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - #set outstring [string map [list \n ] $instring] - set outstring $instring - - return [encoding convertto $o_enc $outstring] - #return [encoding convertto utf-16le $outstring] - } - } - oo::define rebuffer { - method meta_is_redirection {} { - return 0 - } - } - - #has slight buffering/withholding of lone training cr - we can't be sure that a cr at end of chunk is part of \r\n sequence - oo::class create tounix { - variable o_trecord - variable o_enc - variable o_last_char_was_cr - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - set settingsdict [dict get $tf -settings] - if {[dict exists $tf -junction]} { - set o_is_junction [dict get $tf -junction] - } else { - set o_is_junction 0 - } - set o_last_char_was_cr 0 - } - method initialize {transform_handle mode} { - return [list initialize write finalize] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - #don't use read - method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - set outstring $instring - - return [encoding convertto $o_enc $outstring] - } - method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - #set outstring [string map [list \n ] $instring] - - if {$o_last_char_was_cr} { - set instring "\r$instring" - } - - set outstring [string map {\r\n \n} $instring] - set lastchar [string range $outstring end end] - if {$lastchar eq "\r"} { - set o_last_char_was_cr 1 - set outstring [string range $outstring 0 end-1] - } else { - set o_last_char_was_cr 0 - } - #review! can we detect eof here on the transform_handle? - #if eof, we don't want to strip a trailing \r - - return [encoding convertto $o_enc $outstring] - #return [encoding convertto utf-16le $outstring] - } - } - oo::define tounix { - method meta_is_redirection {} { - return $o_is_junction - } - } - #write to handle case where line-endings already \r\n too - oo::class create towindows { - variable o_trecord - variable o_enc - variable o_last_char_was_cr - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - set settingsdict [dict get $tf -settings] - if {[dict exists $tf -junction]} { - set o_is_junction [dict get $tf -junction] - } else { - set o_is_junction 0 - } - set o_last_char_was_cr 0 - } - method initialize {transform_handle mode} { - return [list initialize write finalize] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - #don't use read - method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - set outstring $instring - - return [encoding convertto $o_enc $outstring] - } - method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - #set outstring [string map [list \n ] $instring] - - if {$o_last_char_was_cr} { - set instring "\r$instring" - } - - set outstring [string map {\r\n \uFFFF} $instring] - set outstring [string map {\n \r\n} $outstring] - set outstring [string map {\uFFFF \r\n} $outstring] - - set lastchar [string range $outstring end end] - if {$lastchar eq "\r"} { - set o_last_char_was_cr 1 - set outstring [string range $outstring 0 end-1] - } else { - set o_last_char_was_cr 0 - } - #review! can we detect eof here on the transform_handle? - #if eof, we don't want to strip a trailing \r - - return [encoding convertto $o_enc $outstring] - #return [encoding convertto utf-16le $outstring] - } - } - oo::define towindows { - method meta_is_redirection {} { - return $o_is_junction - } - } - - } -} - -# ---------------------------------------------------------------------------- -#review float/sink metaphor. -#perhaps something with the concept of upstream and downstream? -#need concepts for push towards data, sit in middle where placed, and lag at tail of data stream. -## upstream for stdin is at the bottom of the stack and for stdout is the top of the stack. -#upstream,neutral-upstream,downstream,downstream-aside,downstream-replace (default neutral-upstream - require action 'stack' to use standard channel stacking concept and ignore other actions) -#This is is a bit different from the float/sink metaphor which refers to the channel stacking order as opposed to the data-flow direction. -#The idea would be that whether input or output -# upstream additions go to the side closest to the datasource -# downstream additions go furthest from the datasource -# - all new additions go ahead of any diversions as the most upstream diversion is the current end of the stream in a way. -# - this needs review regarding subsequent removal of the diversion and whether filters re-order in response.. -# or if downstream & neutral additions are reclassified upon insertion if they land among existing upstreams(?) -# neutral-upstream goes to the datasource side of the neutral-upstream list. -# No 'neutral' option provided so that we avoid the need to think forwards or backwards when adding stdin vs stdout shellfilter does the necessary pop/push reordering. -# No 'neutral-downstream' to reduce complexity. -# downstream-replace & downstream-aside head downstream to the first diversion they encounter. ie these actions are no longer referring to the stack direction but only the dataflow direction. -# -# ---------------------------------------------------------------------------- -# -# 'filters' are transforms that don't redirect -# - limited range of actions to reduce complexity. -# - any requirement not fulfilled by float,sink,sink-replace,sink-sideline should be done by multiple pops and pushes -# -#actions can float to top of filters or sink to bottom of filters -#when action is of type sink, it can optionally replace or sideline the first non-filter it encounters (highest redirection on the stack.. any lower are starved of the stream anyway) -# - sideline means to temporarily replace the item and keep a record, restoring if/when we are removed from the transform stack -# -##when action is of type float it can't replace or sideline anything. A float is added above any existing floats and they stay in the same order relative to each other, -#but non-floats added later will sit below all floats. -#(review - float/sink initially designed around output channels. For stdin the dataflow is reversed. implement float-aside etc?) -# -# -#action: float sink sink-replace,sink-sideline -# -# -## note - whether stack is for input or output we maintain it in the same direction - which is in sync with the tcl chan pop chan push concept. -## -namespace eval shellfilter::stack { - namespace export {[a-z]*} - namespace ensemble create - #todo - implement as oo ? - variable pipelines [list] - - proc items {} { - #review - stdin,stdout,stderr act as pre-existing pipelines, and we can't create a new one with these names - so they should probably be autoconfigured and listed.. - # - but in what contexts? only when we find them in [chan names]? - variable pipelines - return [dict keys $pipelines] - } - proc item {pipename} { - variable pipelines - return [dict get $pipelines $pipename] - } - proc item_tophandle {pipename} { - variable pipelines - set handle "" - if {[dict exists $pipelines $pipename stack]} { - set stack [dict get $pipelines $pipename stack] - set topstack [lindex $stack end] ;#last item in stack is top (for output channels anyway) review comment. input chans? - if {$topstack ne ""} { - if {[dict exists $topstack -handle]} { - set handle [dict get $topstack -handle] - } - } - } - return $handle - } - proc status {{pipename *} args} { - variable pipelines - set pipecount [dict size $pipelines] - set tabletitle "$pipecount pipelines active" - set t [textblock::class::table new $tabletitle] - $t add_column -headers [list channel-ident] - $t add_column -headers [list device-info localchan] - $t configure_column 1 -header_colspans {3} - $t add_column -headers [list "" remotechan] - $t add_column -headers [list "" tid] - $t add_column -headers [list stack-info] - foreach k [dict keys $pipelines $pipename] { - set lc [dict get $pipelines $k device localchan] - set rc [dict get $pipelines $k device remotechan] - if {[dict exists $k device workertid]} { - set tid [dict get $pipelines $k device workertid] - } else { - set tid "-" - } - set stack [dict get $pipelines $k stack] - if {![llength $stack]} { - set stackinfo "" - } else { - set tbl_inner [textblock::class::table new] - $tbl_inner configure -show_edge 0 - foreach rec $stack { - set handle [punk::lib::dict_getdef $rec -handle ""] - set id [punk::lib::dict_getdef $rec -id ""] - set transform [namespace tail [punk::lib::dict_getdef $rec -transform ""]] - set settings [punk::lib::dict_getdef $rec -settings ""] - $tbl_inner add_row [list $id $transform $handle $settings] - } - set stackinfo [$tbl_inner print] - $tbl_inner destroy - } - $t add_row [list $k $lc $rc $tid $stackinfo] - } - set result [$t print] - $t destroy - return $result - } - proc status1 {{pipename *} args} { - variable pipelines - - set pipecount [dict size $pipelines] - set tableprefix "$pipecount pipelines active\n" - foreach p [dict keys $pipelines] { - append tableprefix " " $p \n - } - package require overtype - #todo -verbose - set table "" - set ac1 [string repeat " " 15] - set ac2 [string repeat " " 42] - set ac3 [string repeat " " 70] - append table "[overtype::left $ac1 channel-ident] " - append table "[overtype::left $ac2 device-info] " - append table "[overtype::left $ac3 stack-info]" - append table \n - - - set bc1 [string repeat " " 5] ;#stack id - set bc2 [string repeat " " 25] ;#transform - set bc3 [string repeat " " 50] ;#settings - - foreach k [dict keys $pipelines $pipename] { - set lc [dict get $pipelines $k device localchan] - if {[dict exists $k device workertid]} { - set tid [dict get $pipelines $k device workertid] - } else { - set tid "" - } - - - set col1 [overtype::left $ac1 $k] - set col2 [overtype::left $ac2 "localchan: $lc tid:$tid"] - - set stack [dict get $pipelines $k stack] - if {![llength $stack]} { - set col3 $ac3 - } else { - set rec [lindex $stack 0] - set bcol1 [overtype::left $bc1 [dict get $rec -id]] - set bcol2 [overtype::left $bc2 [namespace tail [dict get $rec -transform]]] - set bcol3 [overtype::left $bc3 [dict get $rec -settings]] - set stackrow "$bcol1 $bcol2 $bcol3" - set col3 [overtype::left $ac3 $stackrow] - } - - append table "$col1 $col2 $col3\n" - - - foreach rec [lrange $stack 1 end] { - set col1 $ac1 - set col2 $ac2 - if {[llength $rec]} { - set bc1 [overtype::left $bc1 [dict get $rec -id]] - set bc2 [overtype::left $bc2 [namespace tail [dict get $rec -transform]]] - set bc3 [overtype::left $bc3 [dict get $rec -settings]] - set stackrow "$bc1 $bc2 $bc3" - set col3 [overtype::left $ac3 $stackrow] - } else { - set col3 $ac3 - } - append table "$col1 $col2 $col3\n" - } - - } - return $tableprefix$table - } - #used for output channels - we usually want to sink redirections below the floaters and down to topmost existing redir - proc _get_stack_floaters {stack} { - set floaters [list] - foreach t [lreverse $stack] { - switch -- [dict get $t -action] { - float { - lappend floaters $t - } - default { - break - } - } - } - return [lreverse $floaters] - } - - - - #for output-channel sinking - proc _get_stack_top_redirection {stack} { - set r 0 ;#reverse index - foreach t [lreverse $stack] { - set obj [dict get $t -obj] - if {[$obj meta_is_redirection]} { - set idx [expr {[llength $stack] - ($r + 1) }] ;#forward index - return [list index $idx record $t] - } - incr r - } - #not found - return [list index -1 record {}] - } - #exclude float-locked, locked, sink-locked - proc _get_stack_top_redirection_replaceable {stack} { - set r 0 ;#reverse index - foreach t [lreverse $stack] { - set action [dict get $t -action] - if {![string match "*locked*" $action]} { - set obj [dict get $t -obj] - if {[$obj meta_is_redirection]} { - set idx [expr {[llength $stack] - ($r + 1) }] ;#forward index - return [list index $idx record $t] - } - } - incr r - } - #not found - return [list index -1 record {}] - } - - - #for input-channels ? - proc _get_stack_bottom_redirection {stack} { - set i 0 - foreach t $stack { - set obj [dict get $t -obj] - if {[$obj meta_is_redirection]} { - return [linst index $i record $t] - } - incr i - } - #not found - return [list index -1 record {}] - } - - - proc get_next_counter {pipename} { - variable pipelines - #use dictn incr ? - set counter [dict get $pipelines $pipename counter] - incr counter - dict set pipelines $pipename counter $counter - return $counter - } - - proc unwind {pipename} { - variable pipelines - set stack [dict get $pipelines $pipename stack] - set localchan [dict get $pipelines $pipename device localchan] - foreach tf [lreverse $stack] { - chan pop $localchan - } - dict set pipelines $pipename [list] - } - #todo - proc delete {pipename {wait 0}} { - variable pipelines - set pipeinfo [dict get $pipelines $pipename] - set deviceinfo [dict get $pipeinfo device] - set localchan [dict get $deviceinfo localchan] - unwind $pipename - - #release associated thread - set tid [dict get $deviceinfo workertid] - if {$wait} { - thread::release -wait $tid - } else { - thread::release $tid - } - - #Memchan closes without error - tcl::chan::fifo2 raises something like 'can not find channel named "rc977"' - REVIEW. why? - catch {chan close $localchan} - } - #review - proc name clarity is questionable. remove_stackitem? - proc remove {pipename remove_id} { - variable pipelines - if {![dict exists $pipelines $pipename]} { - puts stderr "WARNING: shellfilter::stack::remove pipename '$pipename' not found in pipelines dict: '$pipelines' [info level -1]" - return - } - set stack [dict get $pipelines $pipename stack] - set localchan [dict get $pipelines $pipename device localchan] - set posn 0 - set idposn -1 - set asideposn -1 - foreach t $stack { - set id [dict get $t -id] - if {$id eq $remove_id} { - set idposn $posn - break - } - #look into asides (only can be one for now) - if {[llength [dict get $t -aside]]} { - set a [dict get $t -aside] - if {[dict get $a -id] eq $remove_id} { - set asideposn $posn - break - } - } - incr posn - } - - if {$asideposn > 0} { - #id wasn't found directly in stack, but in an -aside. we don't need to pop anything - just clear this aside record - set container [lindex $stack $asideposn] - dict set container -aside {} - lset stack $asideposn $container - dict set pipelines $pipename stack $stack - } else { - if {$idposn < 0} { - ::shellfilter::log::write shellfilter "ERROR shellfilter::stack::remove $pipename id '$remove_id' not found" - puts stderr "|WARNING>shellfilter::stack::remove $pipename id '$remove_id' not found" - return 0 - } - set removed_item [lindex $stack $idposn] - - #include idposn in poplist - set poplist [lrange $stack $idposn end] - set stack [lreplace $stack $idposn end] - #pop all chans before adding anything back in! - foreach p $poplist { - chan pop $localchan - } - - if {[llength [dict get $removed_item -aside]]} { - set restore [dict get $removed_item -aside] - set t [dict get $restore -transform] - set tsettings [dict get $restore -settings] - set obj [$t new $restore] - set h [chan push $localchan $obj] - dict set restore -handle $h - dict set restore -obj $obj - lappend stack $restore - } - - #put popped back except for the first one, which we want to remove - foreach p [lrange $poplist 1 end] { - set t [dict get $p -transform] - set tsettings [dict get $p -settings] - set obj [$t new $p] - set h [chan push $localchan $obj] - dict set p -handle $h - dict set p -obj $obj - lappend stack $p - } - dict set pipelines $pipename stack $stack - } - #JMNJMN 2025 review! - #show_pipeline $pipename -note "after_remove $remove_id" - return 1 - } - - #pop a number of items of the top of the stack, add our transform record, and add back all (or the tail of poplist if pushstartindex > 0) - proc insert_transform {pipename stack transformrecord poplist {pushstartindex 0}} { - variable pipelines - set bottom_pop_posn [expr {[llength $stack] - [llength $poplist]}] - set poplist [lrange $stack $bottom_pop_posn end] - set stack [lreplace $stack $bottom_pop_posn end] - - set localchan [dict get $pipelines $pipename device localchan] - foreach p [lreverse $poplist] { - chan pop $localchan - } - set transformname [dict get $transformrecord -transform] - set transformsettings [dict get $transformrecord -settings] - set obj [$transformname new $transformrecord] - set h [chan push $localchan $obj] - dict set transformrecord -handle $h - dict set transformrecord -obj $obj - dict set transformrecord -note "insert_transform" - lappend stack $transformrecord - foreach p [lrange $poplist $pushstartindex end] { - set t [dict get $p -transform] - set tsettings [dict get $p -settings] - set obj [$t new $p] - set h [chan push $localchan $obj] - #retain previous -id - code that added it may have kept reference and not expecting it to change - dict set p -handle $h - dict set p -obj $obj - dict set p -note "re-added" - - lappend stack $p - } - return $stack - } - - #fifo2 - proc new {pipename args} { - variable pipelines - if {($pipename in [dict keys $pipelines]) || ($pipename in [chan names])} { - error "shellfilter::stack::new error: pipename '$pipename' already exists" - } - - set opts [dict merge {-settings {}} $args] - set defaultsettings [dict create -raw 1 -buffering line -direction out] - set targetsettings [dict merge $defaultsettings [dict get $opts -settings]] - - set direction [dict get $targetsettings -direction] - - #pipename is the source/facility-name ? - if {$direction eq "out"} { - set pipeinfo [shellfilter::pipe::open_out $pipename $targetsettings] - } else { - puts stderr "|jn> pipe::open_in $pipename $targetsettings" - set pipeinfo [shellfilter::pipe::open_in $pipename $targetsettings] - } - #open_out/open_in will configure buffering based on targetsettings - - set program_chan [dict get $pipeinfo localchan] - set worker_chan [dict get $pipeinfo remotechan] - set workertid [dict get $pipeinfo workertid] - - - set deviceinfo [dict create pipename $pipename localchan $program_chan remotechan $worker_chan workertid $workertid direction $direction] - dict set pipelines $pipename [list counter 0 device $deviceinfo stack [list]] - - return $deviceinfo - } - #we 'add' rather than 'push' because transforms can float,sink and replace/sideline so they don't necessarily go to the top of the transform stack - proc add {pipename transformname args} { - variable pipelines - #chan names doesn't reflect available channels when transforms are in place - #e.g stdout may exist but show as something like file191f5b0dd80 - if {($pipename ni [dict keys $pipelines])} { - if {[catch {eof $pipename} is_eof]} { - error "shellfilter::stack::add no existing chan or pipename matching '$pipename' in channels:[chan names] or pipelines:$pipelines use stdin/stderr/stdout or shellfilter::stack::new " - } - } - set args [dict merge {-action "" -settings {}} $args] - set action [dict get $args -action] - set transformsettings [dict get $args -settings] - if {[string first "::" $transformname] < 0} { - set transformname ::shellfilter::chan::$transformname - } - if {![llength [info commands $transformname]]} { - error "shellfilter::stack::push unknown transform '$transformname'" - } - - - if {![dict exists $pipelines $pipename]} { - #pipename must be in chan names - existing device/chan - #record a -read and -write end even if the device is only being used as one or the other - set deviceinfo [dict create pipename $pipename localchan $pipename remotechan {}] - dict set pipelines $pipename [list counter 0 device $deviceinfo stack [list]] - } else { - set deviceinfo [dict get $pipelines $pipename device] - } - - set id [get_next_counter $pipename] - set stack [dict get $pipelines $pipename stack] - set localchan [dict get $deviceinfo localchan] - - #we redundantly store chan in each transform - makes debugging clearer - # -encoding similarly could be stored only at the pipeline level (or even queried directly each filter-read/write), - # but here it may help detect unexpected changes during lifetime of the stack and avoids the chance of callers incorrectly using the transform handle?) - # jn - set transform_record [list -id $id -chan $pipename -encoding [chan configure $localchan -encoding] -transform $transformname -aside {} {*}$args] - switch -glob -- $action { - float - float-locked { - set obj [$transformname new $transform_record] - set h [chan push $localchan $obj] - dict set transform_record -handle $h - dict set transform_record -obj $obj - lappend stack $transform_record - } - "" - locked { - set floaters [_get_stack_floaters $stack] - if {![llength $floaters]} { - set obj [$transformname new $transform_record] - set h [chan push $localchan $obj] - dict set transform_record -handle $h - dict set transform_record -obj $obj - lappend stack $transform_record - } else { - set poplist $floaters - set stack [insert_transform $pipename $stack $transform_record $poplist] - } - } - "sink*" { - set redirinfo [_get_stack_top_redirection $stack] - set idx_existing_redir [dict get $redirinfo index] - if {$idx_existing_redir == -1} { - #no existing redirection transform on the stack - #pop everything.. add this record as the first redirection on the stack - set poplist $stack - set stack [insert_transform $pipename $stack $transform_record $poplist] - } else { - switch -glob -- $action { - "sink-replace" { - #include that index in the poplist - set poplist [lrange $stack $idx_existing_redir end] - #pop all from idx_existing_redir to end, but put back 'lrange $poplist 1 end' - set stack [insert_transform $pipename $stack $transform_record $poplist 1] - } - "sink-aside*" { - set existing_redir_record [lindex $stack $idx_existing_redir] - if {[string match "*locked*" [dict get $existing_redir_record -action]]} { - set put_aside 0 - #we can't aside this one - sit above it instead. - set poplist [lrange $stack $idx_existing_redir+1 end] - set stack [lrange $stack 0 $idx_existing_redir] - } else { - set put_aside 1 - dict set transform_record -aside [lindex $stack $idx_existing_redir] - set poplist [lrange $stack $idx_existing_redir end] - set stack [lrange $stack 0 $idx_existing_redir-1] - } - foreach p $poplist { - chan pop $localchan - } - set transformname [dict get $transform_record -transform] - set transform_settings [dict get $transform_record -settings] - set obj [$transformname new $transform_record] - set h [chan push $localchan $obj] - dict set transform_record -handle $h - dict set transform_record -obj $obj - dict set transform_record -note "insert_transform-with-aside" - lappend stack $transform_record - #add back poplist *except* the one we transferred into -aside (if we were able) - foreach p [lrange $poplist $put_aside end] { - set t [dict get $p -transform] - set tsettings [dict get $p -settings] - set obj [$t new $p] - set h [chan push $localchan $obj] - #retain previous -id - code that added it may have kept reference and not expecting it to change - dict set p -handle $h - dict set p -obj $obj - dict set p -note "re-added-after-sink-aside" - lappend stack $p - } - } - default { - #plain "sink" - #we only sink to the topmost redirecting filter - which makes sense for an output channel - #For stdin.. this is more problematic as we're more likely to want to intercept the bottom most redirection. - #todo - review. Consider making default insert position for input channels to be at the source... and float/sink from there. - # - we don't currently know from the stack api if adding input vs output channel - so this needs work to make intuitive. - # consider splitting stack::add to stack::addinput stack::addoutput to split the different behaviour - set poplist [lrange $stack $idx_existing_redir+1 end] - set stack [insert_transform $pipename $stack $transform_record $poplist] - } - } - } - } - default { - error "shellfilter::stack::add unimplemented action '$action'" - } - } - - dict set pipelines $pipename stack $stack - #puts stdout "==" - #puts stdout "==>stack: $stack" - #puts stdout "==" - - #JMNJMN - #show_pipeline $pipename -note "after_add $transformname $args" - return $id - } - proc show_pipeline {pipename args} { - variable pipelines - set stack [dict get $pipelines $pipename stack] - set tag "SHELLFILTER::STACK" - #JMN - load from config - #::shellfilter::log::open $tag {-syslog 127.0.0.1:514} - if {[catch { - ::shellfilter::log::open $tag {-syslog ""} - } err]} { - #e.g safebase interp can't load required modules such as shellthread (or Thread) - puts stderr "shellfilter::show_pipeline cannot open log" - return - } - ::shellfilter::log::write $tag "transform stack for $pipename $args" - foreach tf $stack { - ::shellfilter::log::write $tag " $tf" - } - - } -} - - -namespace eval shellfilter { - variable sources [list] - variable stacks [dict create] - - proc ::shellfilter::redir_channel_to_log {chan args} { - variable sources - set default_logsettings [dict create \ - -tag redirected_$chan -syslog "" -file ""\ - ] - if {[dict exists $args -action]} { - set action [dict get $args -action] - } else { - # action "sink" is a somewhat reasonable default for an output redirection transform - # but it can make it harder to configure a plain ordered stack if the user is not expecting it, so we'll default to stack - # also.. for stdin transform sink makes less sense.. - #todo - default "stack" instead of empty string - set action "" - } - if {[dict exists $args -settings]} { - set logsettings [dict get $args -settings] - } else { - set logsettings {} - } - - set logsettings [dict merge $default_logsettings $logsettings] - set tag [dict get $logsettings -tag] - if {$tag ni $sources} { - lappend sources $tag - } - - set id [shellfilter::stack::add $chan logonly -action $action -settings $logsettings] - return $id - } - - proc ::shellfilter::redir_output_to_log {tagprefix args} { - variable sources - - set default_settings [list -tag ${tagprefix} -syslog "" -file ""] - - set opts [dict create -action "" -settings {}] - set opts [dict merge $opts $args] - set optsettings [dict get $opts -settings] - set settings [dict merge $default_settings $optsettings] - - set tag [dict get $settings -tag] - if {$tag ne $tagprefix} { - error "shellfilter::redir_output_to_log -tag value must match supplied tagprefix:'$tagprefix'. Omit -tag, or make it the same. It will automatically be suffixed with stderr and stdout. Use redir_channel_to_log if you want to separately configure each channel" - } - lappend sources ${tagprefix}stdout ${tagprefix}stderr - - set stdoutsettings $settings - dict set stdoutsettings -tag ${tagprefix}stdout - set stderrsettings $settings - dict set stderrsettings -tag ${tagprefix}stderr - - set idout [redir_channel_to_log stdout -action [dict get $opts -action] -settings $stdoutsettings] - set iderr [redir_channel_to_log stderr -action [dict get $opts -action] -settings $stderrsettings] - - return [list $idout $iderr] - } - - #eg try: set v [list #a b c] - #vs set v {#a b c} - proc list_is_canonical l { - #courtesy DKF via wiki https://wiki.tcl-lang.org/page/BNF+for+Tcl - if {[catch {llength $l}]} {return 0} - string equal $l [list {*}$l] - } - - #return a dict keyed on numerical list index showing info about each element - # - particularly - # 'wouldbrace' to indicate that the item would get braced by Tcl when added to another list - # 'head_tail_chars' to show current first and last character (in case it's wrapped e.g in double or single quotes or an existing set of braces) - proc list_element_info {inputlist} { - set i 0 - set info [dict create] - set testlist [list] - foreach original_item $inputlist { - #--- - # avoid sharing internal rep with original items in the list (avoids shimmering of rep in original list for certain items such as paths) - unset -nocomplain item - append item $original_item {} - #--- - - set iteminfo [dict create] - set itemlen [string length $item] - lappend testlist $item - set tcl_len [string length $testlist] - set diff [expr {$tcl_len - $itemlen}] - if {$diff == 0} { - dict set iteminfo wouldbrace 0 - dict set iteminfo wouldescape 0 - } else { - #test for escaping vs bracing! - set testlistchars [split $testlist ""] - if {([lindex $testlistchars 0] eq "\{") && ([lindex $testlistchars end] eq "\}")} { - dict set iteminfo wouldbrace 1 - dict set iteminfo wouldescape 0 - } else { - dict set iteminfo wouldbrace 0 - dict set iteminfo wouldescape 1 - } - } - set testlist [list] - set charlist [split $item ""] - set char_a [lindex $charlist 0] - set char_b [lindex $charlist 1] - set char_ab ${char_a}${char_b} - set char_y [lindex $charlist end-1] - set char_z [lindex $charlist end] - set char_yz ${char_y}${char_z} - - if { ("{" in $charlist) || ("}" in $charlist) } { - dict set iteminfo has_braces 1 - set innerchars [lrange $charlist 1 end-1] - if {("{" in $innerchars) || ("}" in $innerchars)} { - dict set iteminfo has_inner_braces 1 - } else { - dict set iteminfo has_inner_braces 0 - } - } else { - dict set iteminfo has_braces 0 - dict set iteminfo has_inner_braces 0 - } - - #todo - brace/char counting to determine if actually 'wrapped' - #e.g we could have list element {((abc)} - which appears wrapped if only looking at first and last chars. - #also {(x) (y)} as a list member.. how to treat? - if {$itemlen <= 1} { - dict set iteminfo apparentwrap "not" - } else { - #todo - switch on $char_a$char_z - if {($char_a eq {"}) && ($char_z eq {"})} { - dict set iteminfo apparentwrap "doublequotes" - } elseif {($char_a eq "'") && ($char_z eq "'")} { - dict set iteminfo apparentwrap "singlequotes" - } elseif {($char_a eq "(") && ($char_z eq ")")} { - dict set iteminfo apparentwrap "brackets" - } elseif {($char_a eq "\{") && ($char_z eq "\}")} { - dict set iteminfo apparentwrap "braces" - } elseif {($char_a eq "^") && ($char_z eq "^")} { - dict set iteminfo apparentwrap "carets" - } elseif {($char_a eq "\[") && ($char_z eq "\]")} { - dict set iteminfo apparentwrap "squarebrackets" - } elseif {($char_a eq "`") && ($char_z eq "`")} { - dict set iteminfo apparentwrap "backquotes" - } elseif {($char_a eq "\n") && ($char_z eq "\n")} { - dict set iteminfo apparentwrap "lf-newline" - } elseif {($char_ab eq "\r\n") && ($char_yz eq "\r\n")} { - dict set iteminfo apparentwrap "crlf-newline" - } else { - dict set iteminfo apparentwrap "not-determined" - } - - } - dict set iteminfo wrapbalance "unknown" ;#a hint to caller that apparentwrap is only a guide. todo - possibly make wrapbalance indicate 0 for unbalanced.. and positive numbers for outer-count of wrappings. - #e.g {((x)} == 0 {((x))} == 1 {(x) (y (z))} == 2 - dict set iteminfo head_tail_chars [list $char_a $char_z] - set namemap [list \ - \r cr\ - \n lf\ - {"} doublequote\ - {'} singlequote\ - "`" backquote\ - "^" caret\ - \t tab\ - " " sp\ - "\[" lsquare\ - "\]" rsquare\ - "(" lbracket\ - ")" rbracket\ - "\{" lbrace\ - "\}" rbrace\ - \\ backslash\ - / forwardslash\ - ] - if {[string length $char_a]} { - set char_a_name [string map $namemap $char_a] - } else { - set char_a_name "emptystring" - } - if {[string length $char_z]} { - set char_z_name [string map $namemap $char_z] - } else { - set char_z_name "emptystring" - } - - dict set iteminfo head_tail_names [list $char_a_name $char_z_name] - dict set iteminfo len $itemlen - dict set iteminfo difflen $diff ;#2 for braces, 1 for quoting?, or 0. - dict set info $i $iteminfo - incr i - } - return $info - } - - - #parse bracketed expression (e.g produced by vim "shellxquote=(" ) into a tcl (nested) list - #e.g {(^c:/my spacey/path^ >^somewhere^)} - #e.g {(blah (etc))}" - #Result is always a list - even if only one toplevel set of brackets - so it may need [lindex $result 0] if input is the usual case of {( ...)} - # - because it also supports the perhaps less likely case of: {( ...) unbraced (...)} etc - # Note that - #maintenance warning - duplication in branches for bracketed vs unbracketed! - proc parse_cmd_brackets {str} { - #wordwrappers currently best suited to non-bracket entities - no bracket matching within - anything goes until end-token reached. - # - but.. they only take effect where a word can begin. so a[x y] may be split at the space unless it's within some other wraper e.g " a[x y]" will not break at the space - # todo - consider extending the in-word handling of word_bdepth which is currently only applied to () i.e aaa(x y) is supported but aaa[x y] is not as the space breaks the word up. - set wordwrappers [list \ - "\"" [list "\"" "\"" "\""]\ - {^} [list "\"" "\"" "^"]\ - "'" [list "'" "'" "'"]\ - "\{" [list "\{" "\}" "\}"]\ - {[} [list {[} {]} {]}]\ - ] ;#dict mapping start_character to {replacehead replacetail expectedtail} - set shell_specials [list "|" "|&" "<" "<@" "<<" ">" "2>" ">&" ">>" "2>>" ">>&" ">@" "2>@" "2>@1" ">&@" "&" "&&" ] ;#words/chars that may precede an opening bracket but don't merge with the bracket to form a word. - #puts "pb:$str" - set in_bracket 0 - set in_word 0 - set word "" - set result {} - set word_bdepth 0 - set word_bstack [list] - set wordwrap "" ;#only one active at a time - set bracketed_elements [dict create] - foreach char [split $str ""] { - #puts "c:$char bracketed:$bracketed_elements" - if {$in_bracket > 0} { - if {$in_word} { - if {[string length $wordwrap]} { - #anything goes until end-char - #todo - lookahead and only treat as closing if before a space or ")" ? - lassign [dict get $wordwrappers $wordwrap] _open closing endmark - if {$char eq $endmark} { - set wordwrap "" - append word $closing - dict lappend bracketed_elements $in_bracket $word - set word "" - set in_word 0 - } else { - append word $char - } - } else { - if {$word_bdepth == 0} { - #can potentially close off a word - or start a new one if word-so-far is a shell-special - if {$word in $shell_specials} { - if {$char eq ")"} { - dict lappend bracketed_elements $in_bracket $word - set subresult [dict get $bracketed_elements $in_bracket] - dict set bracketed_elements $in_bracket [list] - incr in_bracket -1 - if {$in_bracket == 0} { - lappend result $subresult - } else { - dict lappend bracketed_elements $in_bracket $subresult - } - set word "" - set in_word 0 - } elseif {[regexp {[\s]} $char]} { - dict lappend bracketed_elements $in_bracket $word - set word "" - set in_word 0 - } elseif {$char eq "("} { - dict lappend bracketed_elements $in_bracket $word - set word "" - set in_word 0 - incr in_bracket - } else { - #at end of shell-specials is another point to look for word started by a wordwrapper char - #- expect common case of things like >^/my/path^ - if {$char in [dict keys $wordwrappers]} { - dict lappend bracketed_elements $in_bracket $word - set word "" - set in_word 1 ;#just for explicitness.. we're straight into the next word. - set wordwrap $char - set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. - } else { - #something unusual.. keep going with word! - append word $char - } - } - } else { - - if {$char eq ")"} { - dict lappend bracketed_elements $in_bracket $word - set subresult [dict get $bracketed_elements $in_bracket] - dict set bracketed_elements $in_bracket [list] - incr in_bracket -1 - if {$in_bracket == 0} { - lappend result $subresult - } else { - dict lappend bracketed_elements $in_bracket $subresult - } - set word "" - set in_word 0 - } elseif {[regexp {[\s]} $char]} { - dict lappend bracketed_elements $in_bracket $word - set word "" - set in_word 0 - } elseif {$char eq "("} { - #ordinary word up-against and opening bracket - brackets are part of word. - incr word_bdepth - append word "(" - } else { - append word $char - } - } - } else { - #currently only () are used for word_bdepth - todo add all or some wordwrappers chars so that the word_bstack can have multiple active. - switch -- $char { - "(" { - incr word_bdepth - lappend word_bstack $char - append word $char - } - ")" { - incr word_bdepth -1 - set word_bstack [lrange $word_bstack 0 end-1] - append word $char - } - default { - #spaces and chars added to word as it's still in a bracketed section - append word $char - } - } - } - } - } else { - - if {$char eq "("} { - incr in_bracket - - } elseif {$char eq ")"} { - set subresult [dict get $bracketed_elements $in_bracket] - dict set bracketed_elements $in_bracket [list] - incr in_bracket -1 - if {$in_bracket == 0} { - lappend result $subresult - } else { - dict lappend bracketed_elements $in_bracket $subresult - } - } elseif {[regexp {[\s]} $char]} { - # - } else { - #first char of word - look for word-wrappers - if {$char in [dict keys $wordwrappers]} { - set wordwrap $char - set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. - } else { - set word $char - } - set in_word 1 - } - } - } else { - if {$in_word} { - if {[string length $wordwrap]} { - lassign [dict get $wordwrappers $wordwrap] _open closing endmark - if {$char eq $endmark} { - set wordwrap "" - append word $closing - lappend result $word - set word "" - set in_word 0 - } else { - append word $char - } - } else { - - if {$word_bdepth == 0} { - if {$word in $shell_specials} { - if {[regexp {[\s]} $char]} { - lappend result $word - set word "" - set in_word 0 - } elseif {$char eq "("} { - lappend result $word - set word "" - set in_word 0 - incr in_bracket - } else { - #at end of shell-specials is another point to look for word started by a wordwrapper char - #- expect common case of things like >^/my/path^ - if {$char in [dict keys $wordwrappers]} { - lappend result $word - set word "" - set in_word 1 ;#just for explicitness.. we're straight into the next word. - set wordwrap $char - set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. - } else { - #something unusual.. keep going with word! - append word $char - } - } - - } else { - if {[regexp {[\s)]} $char]} { - lappend result $word - set word "" - set in_word 0 - } elseif {$char eq "("} { - incr word_bdepth - append word $char - } else { - append word $char - } - } - } else { - switch -- $char { - "(" { - incr word_bdepth - append word $char - } - ")" { - incr word_bdepth -1 - append word $char - } - default { - append word $char - } - } - } - } - } else { - if {[regexp {[\s]} $char]} { - #insig whitespace(?) - } elseif {$char eq "("} { - incr in_bracket - dict set bracketed_elements $in_bracket [list] - } elseif {$char eq ")"} { - error "unbalanced bracket - unable to proceed result so far: $result bracketed_elements:$bracketed_elements" - } else { - #first char of word - look for word-wrappers - if {$char in [dict keys $wordwrappers]} { - set wordwrap $char - set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. - } else { - set word $char - } - set in_word 1 - } - } - } - #puts "----$bracketed_elements" - } - if {$in_bracket > 0} { - error "shellfilter::parse_cmd_brackets missing close bracket. input was '$str'" - } - if {[dict exists $bracketed_elements 0]} { - #lappend result [lindex [dict get $bracketed_elements 0] 0] - lappend result [dict get $bracketed_elements 0] - } - if {$in_word} { - lappend result $word - } - return $result - } - - #only double quote if argument not quoted with single or double quotes - proc dquote_if_not_quoted {a} { - set wrapchars [string cat [string range $a 0 0] [string range $a end end]] - switch -- $wrapchars { - {""} - {''} { - return $a - } - default { - set newinner [string map [list {"} "\\\""] $a] - return "\"$newinner\"" - } - } - } - - #proc dquote_if_not_bracketed/braced? - - #wrap in double quotes if not double-quoted - proc dquote_if_not_dquoted {a} { - set wrapchars [string cat [string range $a 0 0] [string range $a end end]] - switch -- $wrapchars { - {""} { - return $a - } - default { - #escape any inner quotes.. - set newinner [string map [list {"} "\\\""] $a] - return "\"$newinner\"" - } - } - } - proc dquote {a} { - #escape any inner quotes.. - set newinner [string map [list {"} "\\\""] $a] - return "\"$newinner\"" - } - proc get_scriptrun_from_cmdlist_dquote_if_not {cmdlist {shellcmdflag ""}} { - set scr [auto_execok "script"] - if {[string length $scr]} { - #set scriptrun "( $c1 [lrange $cmdlist 1 end] )" - set arg1 [lindex $cmdlist 0] - if {[string first " " $arg1]>0} { - set c1 [dquote_if_not_quoted $arg1] - #set c1 "\"$arg1\"" - } else { - set c1 $arg1 - } - - if {[string length $shellcmdflag]} { - set scriptrun "$shellcmdflag \$($c1 " - } else { - set scriptrun "\$($c1 " - } - #set scriptrun "$c1 " - foreach a [lrange $cmdlist 1 end] { - #set a [string map [list "/" "//"] $a] - #set a [string map [list "\"" "\\\""] $a] - if {[string first " " $a] > 0} { - append scriptrun [dquote_if_not_quoted $a] - } else { - append scriptrun $a - } - append scriptrun " " - } - set scriptrun [string trim $scriptrun] - append scriptrun ")" - #return [list $scr -q -e -c $scriptrun /dev/null] - return [list $scr -e -c $scriptrun /dev/null] - } else { - return $cmdlist - } - } - - proc ::shellfilter::trun {commandlist args} { - #jmn - } - - - # run a command (or tcl script) with tees applied to stdout/stderr/stdin (or whatever channels are being used) - # By the point run is called - any transforms should already be in place on the channels if they're needed. - # The tees will be inline with none,some or all of those transforms depending on how the stack was configured - # (upstream,downstream configured via -float,-sink etc) - proc ::shellfilter::run {commandlist args} { - #must be a list. If it was a shell commandline string. convert it elsewhere first. - - variable sources - set runtag "shellfilter-run" - #set tid [::shellfilter::log::open $runtag [list -syslog 127.0.0.1:514]] - set tid [::shellfilter::log::open $runtag [list -syslog ""]] - if {[catch {llength $commandlist} listlen]} { - set listlen "" - } - ::shellfilter::log::write $runtag " commandlist:'$commandlist' listlen:$listlen strlen:[string length $commandlist]" - - #flush stdout - #flush stderr - - #adding filters with sink-aside will temporarily disable the existing redirection - #All stderr/stdout from the shellcommand will now tee to the underlying stderr/stdout as well as the configured syslog - - set defaults [dict create \ - -teehandle command \ - -outchan stdout \ - -errchan stderr \ - -inchan stdin \ - -tclscript 0 \ - ] - set opts [dict merge $defaults $args] - - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- - set outchan [dict get $opts -outchan] - set errchan [dict get $opts -errchan] - set inchan [dict get $opts -inchan] - set teehandle [dict get $opts -teehandle] - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- - set is_script [dict get $opts -tclscript] - dict unset opts -tclscript ;#don't pass it any further - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- - set teehandle_out ${teehandle}out ;#default commandout - set teehandle_err ${teehandle}err - set teehandle_in ${teehandle}in - - - #puts stdout "shellfilter initialising tee_to_pipe transforms for in/out/err" - - # sources should be added when stack::new called instead(?) - foreach source [list $teehandle_out $teehandle_err] { - if {$source ni $sources} { - lappend sources $source - } - } - set outdeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_out device] - set outpipechan [dict get $outdeviceinfo localchan] - set errdeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_err device] - set errpipechan [dict get $errdeviceinfo localchan] - - #set indeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_in device] - #set inpipechan [dict get $indeviceinfo localchan] - - #NOTE:These transforms are not necessarily at the top of each stack! - #The float/sink mechanism, along with whether existing transforms are diversionary decides where they sit. - set id_out [shellfilter::stack::add $outchan tee_to_pipe -action sink-aside -settings [list -tag $teehandle_out -pipechan $outpipechan]] - set id_err [shellfilter::stack::add $errchan tee_to_pipe -action sink-aside -settings [list -tag $teehandle_err -pipechan $errpipechan]] - - # need to use os level channel handle for stdin - try named pipes (or even sockets) instead of fifo2 for this - # If non os-level channel - the command can't be run with the redirection - # stderr/stdout can be run with non-os handles in the call - - # but then it does introduce issues with terminal-detection and behaviour for stdout at least - # - # input is also a tee - we never want to change the source at this point - just log/process a side-channel of it. - # - #set id_in [shellfilter::stack::add $inchan tee_to_pipe -action sink-aside -settings [list -tag commandin -pipechan $inpipechan]] - - - #set id_out [shellfilter::stack::add stdout tee_to_log -action sink-aside -settings [list -tag shellstdout -syslog 127.0.0.1:514 -file ""]] - #set id_err [shellfilter::stack::add stderr tee_to_log -action sink-aside -settings [list -tag shellstderr -syslog 127.0.0.1:514 -file "stderr.txt"]] - - #we need to catch errors - and ensure stack::remove calls occur. - #An error can be raised if the command couldn't even launch, as opposed to a non-zero exitcode and stderr output from the command itself. - # - if {!$is_script} { - set experiment 0 - if {$experiment} { - try { - set results [exec {*}$commandlist] - set exitinfo [list exitcode 0] - } trap CHILDSTATUS {results options} { - set exitcode [lindex [dict get $options -errorcode] 2] - set exitinfo [list exitcode $exitcode] - } - } else { - if {[catch { - #run process with stdout/stderr/stdin or with configured channels - #set exitinfo [shellcommand_stdout_stderr $commandlist $outchan $errchan $inpipechan {*}$opts] - set exitinfo [shellcommand_stdout_stderr $commandlist $outchan $errchan stdin {*}$opts] - #puts stderr "---->exitinfo $exitinfo" - - #subprocess result should usually have an "exitcode" key - #but for background execution we will get a "pids" key of process ids. - } errMsg]} { - set exitinfo [list error "$errMsg" source shellcommand_stdout_stderr] - } - } - } else { - if {[catch { - #script result - set exitinfo [list result [uplevel #0 [list eval $commandlist]]] - } errMsg]} { - set exitinfo [list error "$errMsg" errorCode $::errorCode errorInfo "$::errorInfo"] - } - } - - - #the previous redirections on the underlying inchan/outchan/errchan items will be restored from the -aside setting during removal - #Remove execution-time Tees from stack - shellfilter::stack::remove stdout $id_out - shellfilter::stack::remove stderr $id_err - #shellfilter::stack::remove stderr $id_in - - - #chan configure stderr -buffering line - #flush stdout - - - ::shellfilter::log::write $runtag " return '$exitinfo'" - ::shellfilter::log::close $runtag - return $exitinfo - } - proc ::shellfilter::logtidyup { {tags {}} } { - variable sources - set worker_errorlist [list] - set tidied_sources [list] - set tidytag "logtidy" - - - # opening a thread or writing to a log/syslog close to possible process exit is probably not a great idea. - # we should ensure the thread already exists early on if we really need logging here. - # - #set tid [::shellfilter::log::open $tidytag {-syslog 127.0.0.1:514}] - #::shellfilter::log::write $tidytag " logtidyuptags '$tags'" - - foreach s $sources { - if {$s eq $tidytag} { - continue - } - #puts "logtidyup source $s" - set close 1 - if {[llength $tags]} { - if {$s ni $tags} { - set close 0 - } - } - if {$close} { - lappend tidied_sources $s - shellfilter::log::close $s - lappend worker_errorlist {*}[shellthread::manager::get_and_clear_errors $s] - } - } - set remaining_sources [list] - foreach s $sources { - if {$s ni $tidied_sources} { - lappend remaining_sources $s - } - } - - #set sources [concat $remaining_sources $tidytag] - set sources $remaining_sources - - #shellfilter::stack::unwind stdout - #shellfilter::stack::unwind stderr - return [list tidied $tidied_sources errors $worker_errorlist] - } - - #package require tcl::chan::null - # e.g set errchan [tcl::chan::null] - # e.g chan push stdout [shellfilter::chan::var new ::some_var] - proc ::shellfilter::shellcommand_stdout_stderr {commandlist outchan errchan inchan args} { - set valid_flags [list \ - -timeout \ - -outprefix \ - -errprefix \ - -debug \ - -copytempfile \ - -outbuffering \ - -errbuffering \ - -inbuffering \ - -readprocesstranslation \ - -outtranslation \ - -stdinhandler \ - -outchan \ - -errchan \ - -inchan \ - -teehandle\ - ] - - set runtag shellfilter-run2 - #JMN - load from config - #set tid [::shellfilter::log::open $runtag [list -syslog "127.0.0.1:514"]] - set tid [::shellfilter::log::open $runtag [list -syslog ""]] - - if {[llength $args] % 2} { - error "Trailing arguments after any positional arguments must be in pairs of the form -argname argvalue. Valid flags are:'$valid_flags'" - } - set invalid_flags [list] - foreach {k -} $args { - switch -- $k { - -timeout - - -outprefix - - -errprefix - - -debug - - -copytempfile - - -outbuffering - - -errbuffering - - -inbuffering - - -readprocesstranslation - - -outtranslation - - -stdinhandler - - -outchan - - -errchan - - -inchan - - -teehandle { - } - default { - lappend invalid_flags $k - } - } - } - if {[llength $invalid_flags]} { - error "Unknown option(s)'$invalid_flags': must be one of '$valid_flags'" - } - #line buffering generally best for output channels.. keeps relative output order of stdout/stdin closer to source order - #there may be data where line buffering is inappropriate, so it's configurable per std channel - #reading inputs with line buffering can result in extraneous newlines as we can't detect trailing data with no newline before eof. - set defaults [dict create \ - -outchan stdout \ - -errchan stderr \ - -inchan stdin \ - -outbuffering none \ - -errbuffering none \ - -readprocesstranslation auto \ - -outtranslation lf \ - -inbuffering none \ - -timeout 900000\ - -outprefix ""\ - -errprefix ""\ - -debug 0\ - -copytempfile 0\ - -stdinhandler ""\ - ] - - - - set args [dict merge $defaults $args] - set outbuffering [dict get $args -outbuffering] - set errbuffering [dict get $args -errbuffering] - set inbuffering [dict get $args -inbuffering] - set readprocesstranslation [dict get $args -readprocesstranslation] - set outtranslation [dict get $args -outtranslation] - set timeout [dict get $args -timeout] - set outprefix [dict get $args -outprefix] - set errprefix [dict get $args -errprefix] - set debug [dict get $args -debug] - set copytempfile [dict get $args -copytempfile] - set stdinhandler [dict get $args -stdinhandler] - - set debugname "shellfilter-debug" - - if {$debug} { - set tid [::shellfilter::log::open $debugname [list -syslog "127.0.0.1:514"]] - ::shellfilter::log::write $debugname " commandlist '$commandlist'" - } - #'clock micros' good enough id for shellcommand calls unless one day they can somehow be called concurrently or sequentially within a microsecond and within the same interp. - # a simple counter would probably work too - #consider other options if an alternative to the single vwait in this function is used. - set call_id [tcl::clock::microseconds] ; - set ::shellfilter::shellcommandvars($call_id,exitcode) "" - set waitvar ::shellfilter::shellcommandvars($call_id,waitvar) - if {$debug} { - ::shellfilter::log::write $debugname " waitvar '$waitvar'" - } - lassign [chan pipe] rderr wrerr - chan configure $wrerr -blocking 0 - - set custom_stderr "" - set lastitem [lindex $commandlist end] - #todo - ensure we can handle 2> file (space after >) - - #review - reconsider the handling of redirections such that tcl-style are handled totally separately to other shell syntaxes! - # - #note 2>@1 must ocur as last word for tcl - but 2@stdout can occur elsewhere - #(2>@stdout echoes to main stdout - not into pipeline) - #To properly do pipelines it looks like we will have to split on | and call this proc multiple times and wire it up accordingly (presumably in separate threads) - - switch -- [string trim $lastitem] { - {&} { - set name [lindex $commandlist 0] - #background execution - stdout and stderr from child still comes here - but process is backgrounded - #FIX! - this is broken for paths with backslashes for example - #set pidlist [exec {*}[concat $name [lrange $commandlist 1 end]]] - set pidlist [exec {*}$commandlist] - return [list pids $pidlist] - } - {2>&1} - {2>@1} { - set custom_stderr {2>@1} ;#use the tcl style - set commandlist [lrange $commandlist 0 end-1] - } - default { - # 2> filename - # 2>> filename - # 2>@ openfileid - set redir2test [string range $lastitem 0 1] - if {$redir2test eq "2>"} { - set custom_stderr $lastitem - set commandlist [lrange $commandlist 0 end-1] - } - } - } - set lastitem [lindex $commandlist end] - - set teefile "" ;#empty string, write, append - #an ugly hack.. because redirections seem to arrive wrapped - review! - #There be dragons here.. - #Be very careful with list manipulation of the commandlist string.. backslashes cause havoc. commandlist must always be a well-formed list. generally avoid string manipulations on entire list or accidentally breaking a list element into parts if it shouldn't be.. - #The problem here - is that we can't always know what was intended on the commandline regarding quoting - - ::shellfilter::log::write $runtag "checking for redirections in $commandlist" - #sometimes we see a redirection without a following space e.g >C:/somewhere - #normalize - switch -regexp -- $lastitem\ - {^>[/[:alpha:]]+} { - set lastitem "> [string range $lastitem 1 end]" - }\ - {^>>[/[:alpha:]]+} { - set lastitem ">> [string range $lastitem 2 end]" - } - - - #for a redirection, we assume either a 2-element list at tail of form {> {some path maybe with spaces}} - #or that the tail redirection is not wrapped.. x y z > {some path maybe with spaces} - #we can't use list methods such as llenth on a member of commandlist - set wordlike_parts [regexp -inline -all {\S+} $lastitem] - - if {([llength $wordlike_parts] >= 2) && ([lindex $wordlike_parts 0] in [list ">>" ">"])} { - #wrapped redirection - but maybe not 'well' wrapped (unquoted filename) - set lastitem [string trim $lastitem] ;#we often see { > something} - - #don't use lassign or lrange on the element itself without checking first - #we can treat the commandlist as a whole as a well formed list but not neccessarily each element within. - #lassign $lastitem redir redirtarget - #set commandlist [lrange $commandlist 0 end-1] - # - set itemchars [split $lastitem ""] - set firstchar [lindex $itemchars 0] - set lastchar [lindex $itemchars end] - - #NAIVE test for double quoted only! - #consider for example {"a" x="b"} - #testing first and last is not decisive - #We need to decide what level of drilling down is even appropriate here.. - #if something was double wrapped - it was perhaps deliberate so we don't interpret it as something(?) - set head_tail_chars [list $firstchar $lastchar] - set doublequoted [expr {[llength [lsearch -all $head_tail_chars "\""]] == 2}] - if {[string equal "\{" $firstchar] && [string equal "\}" $lastchar]} { - set curlyquoted 1 - } else { - set curlyquoted 0 - } - - if {$curlyquoted} { - #these are not the tcl protection brackets but ones supplied in the argument - #it's still not valid to use list operations on a member of the commandlist - set inner [string range $lastitem 1 end-1] - #todo - fix! we still must assume there could be list-breaking data! - set innerwords [regexp -inline -all {\S+} $inner] ;#better than [split $inner] because we don't get extra empty elements for each whitespace char - set redir [lindex $innerwords 0] ;#a *potential* redir - to be tested below - set redirtarget [lrange $innerwords 1 end] ;#all the rest - } elseif {$doublequoted} { - ::shellfilter::log::write $debugname "doublequoting at tail of command '$commandlist'" - set inner [string range $lastitem 1 end-1] - set innerwords [regexp -inline -all {\S+} $inner] - set redir [lindex $innerwords 0] - set redirtarget [lrange $innerwords 1 end] - } else { - set itemwords [regexp -inline -all {\S+} $lastitem] - # e.g > c:\test becomes > {c:\test} - # but > c/mnt/c/test/temp.txt stays as > /mnt/c/test/temp.txt - set redir [lindex $itemwords 0] - set redirtarget [lrange $itemwords 1 end] - } - set commandlist [lrange $commandlist 0 end-1] - - } elseif {[lindex $commandlist end-1] in [list ">>" ">"]} { - #unwrapped redirection - #we should be able to use list operations like lindex and lrange here as the command itself is hopefully still a well formed list - set redir [lindex $commandlist end-1] - set redirtarget [lindex $commandlist end] - set commandlist [lrange $commandlist 0 end-2] - } else { - #no redirection - set redir "" - set redirtarget "" - #no change to command list - } - - - switch -- $redir { - ">>" - ">" { - set redirtarget [string trim $redirtarget "\""] - ::shellfilter::log::write $runtag " have redirection '$redir' to '$redirtarget'" - - set winfile $redirtarget ;#default assumption - switch -glob -- $redirtarget { - "/c/*" { - set winfile "c:/[string range $redirtarget 3 end]" - } - "/mnt/c/*" { - set winfile "c:/[string range $redirtarget 7 end]" - } - } - - if {[file exists [file dirname $winfile]]} { - #containing folder for target exists - if {$redir eq ">"} { - set teefile "write" - } else { - set teefile "append" - } - ::shellfilter::log::write $runtag "Directory exists '[file dirname $winfile]' operation:$teefile" - } else { - #we should be writing to a file.. but can't - ::shellfilter::log::write $runtag "cannot verify directory exists '[file dirname $winfile]'" - } - } - default { - ::shellfilter::log::write $runtag "No redir found!!" - } - } - - #often first element of command list is wrapped and cannot be run directly - #e.g {{ls -l} {> {temp.tmp}}} - #we will assume that if there is a single element which is a pathname containing a space - it is doubly wrapped. - # this may not be true - and the command may fail if it's just {c:\program files\etc} but it is the less common case and we currently have no way to detect. - #unwrap first element.. will not affect if not wrapped anyway (subject to comment above re spaces) - set commandlist [concat [lindex $commandlist 0] [lrange $commandlist 1 end]] - - #todo? - #child process environment. - # - to pass a different environment to the child - we would need to save the env array, modify as required, and then restore the env array. - - #to restore buffering states after run - set remember_in_out_err_buffering [list \ - [chan configure $inchan -buffering] \ - [chan configure $outchan -buffering] \ - [chan configure $errchan -buffering] \ - ] - - set remember_in_out_err_translation [list \ - [chan configure $inchan -translation] \ - [chan configure $outchan -translation] \ - [chan configure $errchan -translation] \ - ] - - - - - - chan configure $inchan -buffering $inbuffering -blocking 0 ;#we are setting up a readable handler for this - so non-blocking ok - chan configure $errchan -buffering $errbuffering - #chan configure $outchan -blocking 0 - chan configure $outchan -buffering $outbuffering ;#don't configure non-blocking. weird duplicate of *second* line occurs if you do. - # - - #-------------------------------------------- - #Tested on windows. Works to stop in output when buffering is none, reading from channel with -translation auto - #cmd, pwsh, tcl - #chan configure $outchan -translation lf - #chan configure $errchan -translation lf - #-------------------------------------------- - chan configure $outchan -translation $outtranslation - chan configure $errchan -translation $outtranslation - - #puts stderr "chan configure $wrerr [chan configure $wrerr]" - if {$debug} { - ::shellfilter::log::write $debugname "COMMAND [list $commandlist] strlen:[string length $commandlist] llen:[llength $commandlist]" - } - #todo - handle custom redirection of stderr to a file? - if {[string length $custom_stderr]} { - #::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist $custom_stderr] a+" - #set rdout [open |[concat $commandlist $custom_stderr] a+] - ::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist [list $custom_stderr <@$inchan]] [list RDONLY]" - set rdout [open |[concat $commandlist [list <@$inchan $custom_stderr]] [list RDONLY]] - set rderr "bogus" ;#so we don't wait for it - } else { - ::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist [list 2>@$wrerr <@$inchan]] [list RDONLY]" - #set rdout [open |[concat $commandlist [list 2>@$wrerr]] a+] - #set rdout [open |[concat $commandlist [list 2>@$wrerr]] [list RDWR]] - - # If we don't redirect stderr to our own tcl-based channel - then the transforms don't get applied. - # This is the whole reason we need these file-event loops. - # Ideally we need something like exec,open in tcl that interacts with transformed channels directly and emits as it runs, not only at termination - # - and that at least appears like a terminal to the called command. - #set rdout [open |[concat $commandlist [list 2>@stderr <@$inchan]] [list RDONLY]] - - - set rdout [open |[concat $commandlist [list 2>@$wrerr <@$inchan]] [list RDONLY]] - - chan configure $rderr -buffering $errbuffering -blocking 0 - chan configure $rderr -translation $readprocesstranslation - } - - - - set command_pids [pid $rdout] - #puts stderr "command_pids: $command_pids" - #tcl::process ensemble only available in 8.7+ - and it didn't prove useful here anyway - # the child process generally won't shut down until channels are closed. - # premature EOF on grandchild process launch seems to be due to lack of terminal emulation when redirecting stdin/stdout. - # worked around in punk/repl using 'script' command as a fake tty. - #set subprocesses [tcl::process::list] - #puts stderr "subprocesses: $subprocesses" - #if {[lindex $command_pids 0] ni $subprocesses} { - # puts stderr "pid [lindex $command_pids 0] not running $errMsg" - #} else { - # puts stderr "pid [lindex $command_pids 0] is running" - #} - - - if {$debug} { - ::shellfilter::log::write $debugname "pipeline pids: $command_pids" - } - - #jjj - - - chan configure $rdout -buffering $outbuffering -blocking 0 - chan configure $rdout -translation $readprocesstranslation - - if {![string length $custom_stderr]} { - chan event $rderr readable [list apply {{chan other wrerr outchan errchan waitfor errprefix errbuffering debug debugname pids} { - if {$errbuffering eq "line"} { - set countchunk [chan gets $chan chunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved - #errprefix only applicable to line buffered output - if {$countchunk >= 0} { - if {[chan eof $chan]} { - puts -nonewline $errchan ${errprefix}$chunk - } else { - puts $errchan "${errprefix}$chunk" - } - } - } else { - set chunk [chan read $chan] - if {[string length $chunk]} { - puts -nonewline $errchan $chunk - } - } - if {[chan eof $chan]} { - flush $errchan ;#jmn - #set subprocesses [tcl::process::list] - #puts stderr "subprocesses: $subprocesses" - #if {[lindex $pids 0] ni $subprocesses} { - # puts stderr "stderr reader: pid [lindex $pids 0] no longer running" - #} else { - # puts stderr "stderr reader: pid [lindex $pids 0] still running" - #} - chan close $chan - #catch {chan close $wrerr} - if {$other ni [chan names]} { - set $waitfor stderr - } - } - }} $rderr $rdout $wrerr $outchan $errchan $waitvar $errprefix $errbuffering $debug $debugname $command_pids] - } - - #todo - handle case where large amount of stdin coming in faster than rdout can handle - #as is - arbitrary amount of memory could be used because we aren't using a filevent for rdout being writable - # - we're just pumping it in to the non-blocking rdout buffers - # ie there is no backpressure and stdin will suck in as fast as possible. - # for most commandlines this probably isn't too big a deal.. but it could be a problem for multi-GB disk images etc - # - # - - ## Note - detecting trailing missing nl before eof is basically the same here as when reading rdout from executable - # - but there is a slight difference in that with rdout we get an extra blocked state just prior to the final read. - # Not known if that is significant - ## with inchan configured -buffering line - #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl -r cat - #warning reading input with -buffering line. Cannot detect missing trailing-newline at eof - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:0 eof:0 pend:-1 count:3 - #etc - #instate b:0 eof:1 pend:-1 count:-1 - - #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl -r cat - #warning reading input with -buffering line. Cannot detect missing trailing-newline at eof - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:0 eof:1 pend:-1 count:3 - #etc - - if 0 { - chan event $inchan readable [list apply {{chan wrchan inbuffering waitfor} { - #chan copy stdin $chan ;#doesn't work in a chan event - if {$inbuffering eq "line"} { - set countchunk [chan gets $chan chunk] - #puts $wrchan "stdinstate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" - if {$countchunk >= 0} { - if {[chan eof $chan]} { - puts -nonewline $wrchan $chunk - } else { - puts $wrchan $chunk - } - } - } else { - set chunk [chan read $chan] - if {[string length $chunk]} { - puts -nonewline $wrchan $chunk - } - } - if {[chan eof $chan]} { - puts stderr "|stdin_reader>eof [chan configure stdin]" - chan event $chan readable {} - #chan close $chan - chan close $wrchan write ;#half close - #set $waitfor "stdin" - } - }} $inchan $rdout $inbuffering $waitvar] - - if {[string length $stdinhandler]} { - chan configure stdin -buffering line -blocking 0 - chan event stdin readable $stdinhandler - } - } - - set actual_proc_out_buffering [chan configure $rdout -buffering] - set actual_outchan_buffering [chan configure $outchan -buffering] - #despite whatever is configured - we match our reading to how we need to output - set read_proc_out_buffering $actual_outchan_buffering - - - - if {[string length $teefile]} { - set logname "redir_[string map {: _} $winfile]_[tcl::clock::microseconds]" - set tid [::shellfilter::log::open $logname {-syslog 127.0.0.1:514}] - if {$teefile eq "write"} { - ::shellfilter::log::write $logname "opening '$winfile' for write" - set fd [open $winfile w] - } else { - ::shellfilter::log::write $logname "opening '$winfile' for appending" - set fd [open $winfile a] - } - #chan configure $fd -translation lf - chan configure $fd -translation $outtranslation - chan configure $fd -encoding utf-8 - - set tempvar_bytetotal [namespace current]::totalbytes[tcl::clock::microseconds] - set $tempvar_bytetotal 0 - chan event $rdout readable [list apply {{chan other wrerr outchan errchan read_proc_out_buffering waitfor outprefix call_id debug debugname writefile writefilefd copytempfile bytevar logtag} { - #review - if we write outprefix to normal stdout.. why not to redirected file? - #usefulness of outprefix is dubious - upvar $bytevar totalbytes - if {$read_proc_out_buffering eq "line"} { - #set outchunk [chan read $chan] - set countchunk [chan gets $chan outchunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved - if {$countchunk >= 0} { - if {![chan eof $chan]} { - set numbytes [expr {[string length $outchunk] + 1}] ;#we are assuming \n not \r\n - but count won't/can't be completely accurate(?) - review - puts $writefilefd $outchunk - } else { - set numbytes [string length $outchunk] - puts -nonewline $writefilefd $outchunk - } - incr totalbytes $numbytes - ::shellfilter::log::write $logtag "${outprefix} wrote $numbytes bytes to $writefile" - #puts $outchan "${outprefix} wrote $numbytes bytes to $writefile" - } - } else { - set outchunk [chan read $chan] - if {[string length $outchunk]} { - puts -nonewline $writefilefd $outchunk - set numbytes [string length $outchunk] - incr totalbytes $numbytes - ::shellfilter::log::write $logtag "${outprefix} wrote $numbytes bytes to $writefile" - } - } - if {[chan eof $chan]} { - flush $writefilefd ;#jmn - #set blocking so we can get exit code - chan configure $chan -blocking 1 - catch {::shellfilter::log::write $logtag "${outprefix} total bytes $totalbytes written to $writefile"} - #puts $outchan "${outprefix} total bytes $totalbytes written to $writefile" - catch {close $writefilefd} - if {$copytempfile} { - catch {file copy $writefile "[file rootname $writefile]_copy[file extension $writefile]"} - } - try { - chan close $chan - set ::shellfilter::shellcommandvars($call_id,exitcode) 0 - if {$debug} { - ::shellfilter::log::write $debugname "(teefile) -- child process returned no error. (exit code 0) --" - } - } trap CHILDSTATUS {result options} { - set code [lindex [dict get $options -errorcode] 2] - if {$debug} { - ::shellfilter::log::write $debugname "(teefile) CHILD PROCESS EXITED with code: $code" - } - set ::shellfilter::shellcommandvars($call_id,exitcode) $code - } - catch {chan close $wrerr} - if {$other ni [chan names]} { - set $waitfor stdout - } - } - }} $rdout $rderr $wrerr $outchan $errchan $read_proc_out_buffering $waitvar $outprefix $call_id $debug $debugname $winfile $fd $copytempfile $tempvar_bytetotal $logname] - - } else { - - # This occurs when we have outbuffering set to 'line' - as the 'input' from rdout which comes from the executable is also configured to 'line' - # where b:0|1 is whether chan blocked $chan returns 0 or 1 - # pend is the result of chan pending $chan - # eof is the resot of chan eof $chan - - - ##------------------------- - ##If we still read with gets,to retrieve line by line for output to line-buffered output - but the input channel is configured with -buffering none - ## then we can detect the difference - # there is an extra blocking read - but we can stil use eof with data to detect the absent newline and avoid passing an extra one on. - #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl /c cat - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:0 eof:0 pend:-1 count:3 - #etc - #instate b:0 eof:1 pend:-1 count:-1 - - #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl /u/c cat - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:1 eof:0 pend:-1 count:-1 - #instate b:0 eof:1 pend:-1 count:3 - #etc - ##------------------------ - - - #this should only occur if upstream is coming from stdin reader that has line buffering and hasn't handled the difference properly.. - ###reading with gets from line buffered input with trailing newline - #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl /c cat - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:0 eof:0 pend:-1 count:3 - #etc - #instate b:0 eof:1 pend:-1 count:-1 - - ###reading with gets from line buffered input with trailing newline - ##No detectable difference! - #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl /c cat - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:0 eof:0 pend:-1 count:3 - #etc - #instate b:0 eof:1 pend:-1 count:-1 - ##------------------------- - - #Note that reading from -buffering none and writing straight out gives no problem because we pass the newlines through as is - - - #set ::shellfilter::chan::lastreadblocked_nodata_noeof($rdout) 0 ;#a very specific case of readblocked prior to eof.. possibly not important - #this detection is disabled for now - but left for debugging in case it means something.. or changes - chan event $rdout readable [list apply {{chan other wrerr outchan errchan read_proc_out_buffering waitfor outprefix call_id debug debugname pids} { - #set outchunk [chan read $chan] - - if {$read_proc_out_buffering eq "line"} { - set countchunk [chan gets $chan outchunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved - #countchunk can be -1 before eof e.g when blocked - #debugging output inline with data - don't leave enabled - #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" - if {$countchunk >= 0} { - if {![chan eof $chan]} { - puts $outchan ${outprefix}$outchunk - } else { - puts -nonewline $outchan ${outprefix}$outchunk - #if {$::shellfilter::chan::lastreadblocked_nodata_noeof($chan)} { - # seems to be the usual case - #} else { - # #false alarm, or ? we've reached eof with data but didn't get an empty blocking read just prior - # #Not known if this occurs - # #debugging output inline with data - don't leave enabled - # puts $outchan "!!!prev read didn't block: instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" - #} - } - #set ::shellfilter::chan::lastreadblocked_nodata_noeof($chan) 0 - } else { - #set ::shellfilter::chan::lastreadblocked_nodata_noeof($chan) [expr {[chan blocked $chan] && ![chan eof $chan]}] - } - } else { - #puts $outchan "read CHANNEL $chan [chan configure $chan]" - #puts $outchan "write CHANNEL $outchan b:[chan configure $outchan -buffering] t:[chan configure $outchan -translation] e:[chan configure $outchan -encoding]" - set outchunk [chan read $chan] - #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:[string length $outchunk]" - if {[string length $outchunk]} { - #set stringrep [encoding convertfrom utf-8 $outchunk] - #set newbytes [encoding convertto utf-16 $stringrep] - #puts -nonewline $outchan $newbytes - puts -nonewline $outchan $outchunk - } - } - - if {[chan eof $chan]} { - flush $outchan ;#jmn - #for now just look for first element in the pid list.. - #set subprocesses [tcl::process::list] - #puts stderr "subprocesses: $subprocesses" - #if {[lindex $pids 0] ni $subprocesses} { - # puts stderr "stdout reader pid: [lindex $pids 0] no longer running" - #} else { - # puts stderr "stdout reader pid: [lindex $pids 0] still running" - #} - - #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan]" - chan configure $chan -blocking 1 ;#so we can get exit code - try { - chan close $chan - set ::shellfilter::shellcommandvars($call_id,exitcode) 0 - if {$debug} { - ::shellfilter::log::write $debugname " -- child process returned no error. (exit code 0) --" - } - } trap CHILDSTATUS {result options} { - set code [lindex [dict get $options -errorcode] 2] - set ::shellfilter::shellcommandvars($call_id,exitcode) $code - if {$debug} { - ::shellfilter::log::write $debugname " CHILD PROCESS EXITED with code: $code" - } - } trap CHILDKILLED {result options} { - #set code [lindex [dict get $options -errorcode] 2] - #set ::shellfilter::shellcommandvars(%id%,exitcode) $code - set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled" - if {$debug} { - ::shellfilter::log::write $debugname " CHILD PROCESS EXITED with result:'$result' options:'$options'" - } - - } finally { - #puts stdout "HERE" - #flush stdout - - } - catch {chan close $wrerr} - if {$other ni [chan names]} { - set $waitfor stdout - } - - } - }} $rdout $rderr $wrerr $outchan $errchan $read_proc_out_buffering $waitvar $outprefix $call_id $debug $debugname $command_pids] - } - - #todo - add ability to detect activity/data-flow and change timeout to only apply for period with zero data - #e.g x hrs with no data(?) - #reset timeout when data detected. - after $timeout [string map [list %w% $waitvar %id% $call_id %wrerr% $wrerr %rdout% $rdout %rderr% $rderr %debug% $debug %debugname% $debugname] { - if {[info exists ::shellfilter::shellcommandvars(%id%,exitcode)]} { - if {[set ::shellfilter::shellcommandvars(%id%,exitcode)] ne ""} { - catch { chan close %wrerr% } - catch { chan close %rdout%} - catch { chan close %rderr%} - } else { - chan configure %rdout% -blocking 1 - try { - chan close %rdout% - set ::shellfilter::shellcommandvars(%id%,exitcode) 0 - if {%debug%} { - ::shellfilter::log::write %debugname% "(timeout) -- child process returned no error. (exit code 0) --" - } - } trap CHILDSTATUS {result options} { - set code [lindex [dict get $options -errorcode] 2] - if {%debug%} { - ::shellfilter::log::write %debugname% "(timeout) CHILD PROCESS EXITED with code: $code" - } - set ::shellfilter::shellcommandvars(%id%,exitcode) $code - } trap CHILDKILLED {result options} { - set code [lindex [dict get $options -errorcode] 2] - #set code [dict get $options -code] - #set ::shellfilter::shellcommandvars(%id%,exitcode) $code - #set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled-timeout" - set ::shellfilter::shellcommandvars(%id%,exitcode) "childkilled-timeout" - if {%debug%} { - ::shellfilter::log::write %debugname% "(timeout) CHILDKILLED with code: $code" - ::shellfilter::log::write %debugname% "(timeout) result:$result options:$options" - } - - } - catch { chan close %wrerr% } - catch { chan close %rderr%} - } - set %w% "timeout" - } - }] - - - vwait $waitvar - - set exitcode [set ::shellfilter::shellcommandvars($call_id,exitcode)] - if {![string is digit -strict $exitcode]} { - puts stderr "Process exited with non-numeric code: $exitcode" - flush stderr - } - if {[string length $teefile]} { - #cannot be called from within an event handler above.. vwait reentrancy etc - catch {::shellfilter::log::close $logname} - } - - if {$debug} { - ::shellfilter::log::write $debugname " closed by: [set $waitvar] with exitcode: $exitcode" - catch {::shellfilter::log::close $debugname} - } - array unset ::shellfilter::shellcommandvars $call_id,* - - - #restore buffering to pre shellfilter::run state - lassign $remember_in_out_err_buffering bin bout berr - chan configure $inchan -buffering $bin - chan configure $outchan -buffering $bout - chan configure $errchan -buffering $berr - - lassign $remember_in_out_err_translation tin tout terr - chan configure $inchan -translation $tin - chan configure $outchan -translation $tout - chan configure $errchan -translation $terr - - - #in channel probably closed..(? review - should it be?) - catch { - chan configure $inchan -buffering $bin - } - - - return [list exitcode $exitcode] - } - -} - -package provide shellfilter [namespace eval shellfilter { - variable version - set version 0.1.9 -}] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellrun-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellrun-0.1.1.tm index 8f03892d..478c70fa 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellrun-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellrun-0.1.1.tm @@ -222,6 +222,9 @@ namespace eval shellrun { } set resolved_cmdname [auto_execok $cmdname] + if {$resolved_cmdname eq ""} { + error "Cannot find path for executable '$cmdname'" + } set repl_runid [punk::get_repl_runid] #set ::punk::last_run_display [list] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.1.tm deleted file mode 100644 index d7a828a4..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.1.tm +++ /dev/null @@ -1,7408 +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) 2023 -# -# @@ Meta Begin -# Application textblock 0.1.1 -# Meta platform tcl -# Meta license -# @@ Meta End - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_textblock 0 0.1.1] -#[copyright "2024"] -#[titledesc {punk textblock functions}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk textblock}] [comment {-- Description at end of page heading --}] -#[require textblock] -#[keywords module utility lib] -#[description] -#[para] Ansi-aware terminal textblock manipulation - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of textblock -#[subsection Concepts] -#[para] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by textblock -#[list_begin itemized] - -#*** !doctools -#[item] [package {Tcl 8.6-}] -#[item] [package {punk::args}] -#[item] [package {punk::char}] -#[item] [package {punk::ansi}] -#[item] [package {punk::lib}] -#[item] [package {overtype}] -#[item] [package {term::ansi::code::macros}] -#[item] [package {textutil}] - -## Requirements -package require Tcl 8.6- -package require punk::args -package require punk::char -package require punk::ansi -package require punk::lib -catch {package require patternpunk} -package require overtype - -#safebase interps as at 2024-08 can't access deeper paths - even though they are below the supposed safe list. -package require term::ansi::code::macros ;#required for frame if old ansi g0 used - review - make package optional? -package require textutil - - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -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 - variable use_md5 ;#framecache - set use_md5 1 - if {[catch {package require md5}]} { - set use_md5 0 - } - proc use_md5 {{yes_no ""}} { - variable use_md5 - if {$yes_no eq ""} { - return $use_md5 - } - if {![string is boolean -strict $yes_no]} { - error "textblock::use_md5 requires a boolean (or empty string to query)" - } - if {$yes_no} { - package require md5 - set use_md5 1 - } else { - set use_md5 0 - } - return $use_md5 - } - tcl::namespace::eval class { - variable opts_table_defaults - set opts_table_defaults [tcl::dict::create\ - -title ""\ - -titlealign "left"\ - -titletransparent 0\ - -frametype "light"\ - -frametype_header ""\ - -ansibase_header ""\ - -ansibase_body ""\ - -ansibase_footer ""\ - -ansiborder_header ""\ - -ansiborder_body ""\ - -ansiborder_footer ""\ - -ansireset "\uFFeF"\ - -framelimits_header "vll vlr hlb hlt tlc trc blc brc"\ - -frametype_body ""\ - -framelimits_body "vll vlr hlb hlt tlc trc blc brc"\ - -framemap_body [list\ - topleft {} topinner {} topright {} topsolo {}\ - middleleft {} middleinner {} middleright {} middlesolo {}\ - bottomleft {} bottominner {} bottomright {} bottomsolo {}\ - onlyleft {} onlyinner {} onlyright {} onlysolo {}\ - ]\ - -framemap_header [list\ - topleft {} topinner {} topright {} topsolo {}\ - middleleft {} middleinner {} middleright {} middlesolo {}\ - bottomleft {} bottominner {} bottomright {} bottomsolo {}\ - onlyleft {} onlyinner {} onlyright {} onlysolo {}\ - ]\ - -show_edge 1\ - -show_seps 1\ - -show_hseps ""\ - -show_vseps ""\ - -show_header ""\ - -show_footer ""\ - -minwidth ""\ - -maxwidth ""\ - ] - variable opts_column_defaults - set opts_column_defaults [tcl::dict::create\ - -headers [list]\ - -header_colspans [list]\ - -footers [list]\ - -defaultvalue ""\ - -ansibase ""\ - -ansireset "\uFFEF"\ - -minwidth ""\ - -maxwidth ""\ - -blockalign centre\ - -textalign left\ - ] - #initialise -ansireset with replacement char so we can keep in appropriate dict position for initial configure and then treat as read-only - - - - #for 'L' shaped table building pattern (tables bigger than 4x4 will be mostly 'L' patterns) - #ie only vll,blc,hlb used for cells except top row and right column - #top right cell uses all 'O' shape, other top cells use 'C' shape (hlt,tlc,vll,blc,hlb) - #right cells use 'U' shape (vll,blc,hlb,brc,vlr) - #e.g for 4x4 - # C C C O - # L L L U - # L L L U - #anti-clockwise elements - set C [list hlt tlc vll blc hlb] - set O [list trc hlt tlc vll blc hlb brc vlr] - set L [list vll blc hlb] - set U [list vll blc hlb brc vlr] - set tops [list trc hlt tlc] - set lefts [list tlc vll blc] - set bottoms [list blc hlb brc] - set rights [list trc brc vlr] - - variable table_edge_parts - set table_edge_parts [tcl::dict::create\ - topleft [struct::set intersect $C [concat $tops $lefts]]\ - topinner [struct::set intersect $C [concat $tops]]\ - topright [struct::set intersect $O [concat $tops $rights]]\ - topsolo [struct::set intersect $O [concat $tops $lefts $rights]]\ - middleleft [struct::set intersect $L $lefts]\ - middleinner [list]\ - middleright [struct::set intersect $U $rights]\ - middlesolo [struct::set intersect $U [concat $lefts $rights]]\ - bottomleft [struct::set intersect $L [concat $lefts $bottoms]]\ - bottominner [struct::set intersect $L $bottoms]\ - bottomright [struct::set intersect $U [concat $bottoms $rights]]\ - bottomsolo [struct::set intersect $U [concat $lefts $bottoms $rights]]\ - onlyleft [struct::set intersect $C [concat $tops $lefts $bottoms]]\ - onlyinner [struct::set intersect $C [concat $tops $bottoms]]\ - onlyright [struct::set intersect $O [concat $tops $bottoms $rights]]\ - onlysolo [struct::set intersect $O [concat $tops $lefts $bottoms $rights]]\ - ] - - #for header rows - we don't consider the bottom border as part of the edge - even if table body has no rows - #The usual-case of a single header line is the 'onlyleft,onlyinner,onlyright,onlysolo' set. - variable header_edge_parts - set header_edge_parts [tcl::dict::create\ - topleft [struct::set intersect $C [concat $tops $lefts]]\ - topinner [struct::set intersect $C [concat $tops]]\ - topright [struct::set intersect $O [concat $tops $rights]]\ - topsolo [struct::set intersect $O [concat $tops $lefts $rights]]\ - middleleft [struct::set intersect $L $lefts]\ - middleinner [list]\ - middleright [struct::set intersect $U $rights]\ - middlesolo [struct::set intersect $U [concat $lefts $rights]]\ - bottomleft [struct::set intersect $L [concat $lefts]]\ - bottominner [list]\ - bottomright [struct::set intersect $U $rights]\ - bottomsolo [struct::set intersect $U [concat $lefts $rights]]\ - onlyleft [struct::set intersect $C [concat $tops $lefts]]\ - onlyinner [struct::set intersect $C $tops]\ - onlyright [struct::set intersect $O [concat $tops $rights]]\ - onlysolo [struct::set intersect $O [concat $tops $lefts $rights]]\ - ] - variable table_hseps - set table_hseps [tcl::dict::create\ - topleft [list blc hlb]\ - topinner [list blc hlb]\ - topright [list blc hlb brc]\ - topsolo [list blc hlb brc]\ - middleleft [list blc hlb]\ - middleinner [list blc hlb]\ - middleright [list blc hlb brc]\ - middlesolo [list blc hlb brc]\ - bottomleft [list]\ - bottominner [list]\ - bottomright [list]\ - bottomsolo [list]\ - onlyleft [list]\ - onlyinner [list]\ - onlyright [list]\ - onlysolo [list]\ - ] - variable table_vseps - set table_vseps [tcl::dict::create\ - topleft [list]\ - topinner [list vll tlc blc]\ - topright [list vll tlc blc]\ - topsolo [list]\ - middleleft [list]\ - middleinner [list vll tlc blc]\ - middleright [list vll tlc blc]\ - middlesolo [list]\ - bottomleft [list]\ - bottominner [list vll tlc blc]\ - bottomright [list vll tlc blc]\ - bottomsolo [list]\ - onlyleft [list]\ - onlyinner [list vll tlc blc]\ - onlyright [list vll tlc blc]\ - onlysolo [list]\ - ] - - #ensembles seem to be not compiled in safe interp - #https://core.tcl-lang.org/tcl/tktview/1095bf7f75 - #as we want textblock to be usable in safe interps - use tcl::dict::for as a partial workaround - #This at least means the script argument, especially switch statements can get compiled. - #It does however affect all ensemble commands - so even 'dict get/set' etc won't be as efficient in a safe interp. - - #e.g $t configure -framemap_body [table_edge_map " "] - proc table_edge_map {char} { - variable table_edge_parts - set map [list] - tcl::dict::for {celltype parts} $table_edge_parts { - set tmap [list] - foreach p $parts { - tcl::dict::set tmap $p $char - } - tcl::dict::set map $celltype $tmap - } - return $map - } - proc table_sep_map {char} { - variable table_hseps - set map [list] - tcl::dict::for {celltype parts} $table_hseps { - set tmap [list] - foreach p $parts { - tcl::dict::set tmap $p $char - } - tcl::dict::set map $celltype $tmap - } - return $map - } - proc header_edge_map {char} { - variable header_edge_parts - set map [list] - tcl::dict::for {celltype parts} $header_edge_parts { - set tmap [list] - foreach p $parts { - tcl::dict::set tmap $p $char - } - tcl::dict::set map $celltype $tmap - } - return $map - } - - if {[tcl::info::commands [tcl::namespace::current]::table] eq ""} { - #*** !doctools - #[subsection {Namespace textblock::class}] - #[para] class definitions - #[list_begin itemized] [comment {- textblock::class groupings -}] - # [item] - # [para] [emph {handler_classes}] - # [list_begin enumerated] - - #this makes new table objects a little faster when multiple opts specified as well as to configure - #as tables are a heavyweight thing, but handy to nest sometimes - we'll take what we can get - set topt_keys [tcl::dict::keys $::textblock::class::opts_table_defaults] - set switch_keys_valid_topts [punk::lib::lmapflat v $topt_keys {list $v -}] - set switch_keys_valid_topts [lrange $switch_keys_valid_topts 0 end-1] ;#remove last dash - - set copt_keys [tcl::dict::keys $::textblock::class::opts_column_defaults] - set switch_keys_valid_copts [punk::lib::lmapflat v $copt_keys {list $v -}] - set switch_keys_valid_copts [lrange $switch_keys_valid_copts 0 end-1] - - oo::class create [tcl::namespace::current]::table [tcl::string::map [list %topt_keys% $topt_keys %topt_switchkeys% $switch_keys_valid_topts %copt_keys% $copt_keys %copt_switchkeys% $switch_keys_valid_copts] { - #*** !doctools - #[enum] CLASS [class textblock::class::table] - #[list_begin definitions] - # [para] [emph METHODS] - variable o_opts_table ;#options as configured by user (with exception of -ansireset) - variable o_opts_table_effective; #options in effect - e.g with defaults merged in. - - variable o_columndefs - variable o_columndata - variable o_columnstates - variable o_headerstates - - variable o_rowdefs - variable o_rowstates - - variable o_opts_table_defaults - variable o_opts_header_defaults ;# header data mostly stored in o_columndefs - variable o_opts_column_defaults - variable o_opts_row_defaults - variable TSUB ;#make configurable so user isn't stopped from using our default PUA-unicode char in content (nerdfonts overlap) - variable o_calculated_column_widths - variable o_column_width_algorithm - - - constructor {args} { - #*** !doctools - #[call class::table [method constructor] [arg args]] - set o_opts_table_defaults $::textblock::class::opts_table_defaults - set o_opts_column_defaults $::textblock::class::opts_column_defaults - - - if {[llength $args] == 1} { - set args [list -title [lindex $args 0]] - } - if {[llength $args] %2 !=0} { - error "[tcl::namespace::current]::table constructor - unexpected argument count. Require single value being title, or name value pairs" - } - - set o_opts_table $o_opts_table_defaults - set o_opts_table_effective $o_opts_table_defaults - - ##todo - test with punk::lib::show_jump_tables - how? - foreach {k v} $args { - switch -- $k { - %topt_switchkeys% { - tcl::dict::set o_opts_table $k $v - } - default { - error "[tcl::namespace::current]::table unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" - } - } - } - my configure {*}$o_opts_table - - #foreach {k v} $args { - # #todo - convert to literal switch using tcl::string::map so we don't have to define o_opts_table_defaults here. - # if {$k ni [tcl::dict::keys $o_opts_table_defaults]} { - # error "[tcl::namespace::current]::table unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" - # } - #} - #set o_opts_table [tcl::dict::merge $o_opts_table_defaults $args] - #my configure {*}[tcl::dict::merge $o_opts_table_defaults $args] - - set o_columndefs [tcl::dict::create] - set o_columndata [tcl::dict::create] ;#we store data by column even though it is often added row by row - set o_columnstates [tcl::dict::create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly - set o_headerstates [tcl::dict::create] - set o_rowdefs [tcl::dict::create] ;#user requested row data e.g -minheight -maxheight - set o_rowstates [tcl::dict::create] ;#actual row data such as -minheight and -maxheight detected from supplied row data - - set TSUB \uF111 ;#should be BMP PUA code to show as either replacement char or nerdfont glyph. See FSUB for comments regarding choices. - set o_calculated_column_widths [list] - set o_column_width_algorithm "span" - set header_defaults [tcl::dict::create\ - -colspans {}\ - -values {}\ - -ansibase {}\ - ] - set o_opts_header_defaults $header_defaults - } - - method width_algorithm {{alg ""}} { - if {$alg eq ""} { - return $o_column_width_algorithm - } - if {$alg ne $o_column_width_algorithm} { - #invalidate cached widths - set o_calculated_column_widths [list] - } - set o_column_width_algorithm $alg - } - method Get_seps {} { - set requested_seps [tcl::dict::get $o_opts_table -show_seps] - set requested_seps_h [tcl::dict::get $o_opts_table -show_hseps] - set requested_seps_v [tcl::dict::get $o_opts_table -show_vseps] - set seps $requested_seps - set seps_h $requested_seps_h - set seps_v $requested_seps_v - if {$requested_seps eq ""} { - if {$requested_seps_h eq ""} { - set seps_h 1 - } - if {$requested_seps_v eq ""} { - set seps_v 1 - } - } else { - if {$requested_seps_h eq ""} { - set seps_h $seps - } - if {$requested_seps_v eq ""} { - set seps_v $seps - } - } - return [tcl::dict::create horizontal $seps_h vertical $seps_v] - } - method Get_frametypes {} { - set requested_ft [tcl::dict::get $o_opts_table -frametype] - set requested_ft_header [tcl::dict::get $o_opts_table -frametype_header] - set requested_ft_body [tcl::dict::get $o_opts_table -frametype_body] - set ft $requested_ft - set ft_header $requested_ft_header - set ft_body $requested_ft_body - switch -- $requested_ft { - light { - if {$requested_ft_header eq ""} { - set ft_header heavy - } - if {$requested_ft_body eq ""} { - set ft_body light - } - } - default { - if {$requested_ft_header eq ""} { - set ft_header $requested_ft - } - if {$requested_ft_body eq ""} { - set ft_body $requested_ft - } - } - } - return [tcl::dict::create header $ft_header body $ft_body] - } - method Set_effective_framelimits {} { - upvar ::textblock::class::opts_table_defaults tdefaults - set default_blims [tcl::dict::get $tdefaults -framelimits_body] - set default_hlims [tcl::dict::get $tdefaults -framelimits_header] - set eff_blims [tcl::dict::get $o_opts_table_effective -framelimits_body] - set eff_hlims [tcl::dict::get $o_opts_table_effective -framelimits_header] - - set requested_blims [tcl::dict::get $o_opts_table -framelimits_body] - set requested_hlims [tcl::dict::get $o_opts_table -framelimits_header] - set blims $eff_blims - set hlims $eff_hlims - switch -- $requested_blims { - "default" { - set blims $default_blims - } - default { - #set blims $requested_blims - set blims [list] - foreach lim $requested_blims { - switch -- $lim { - hl { - lappend blims hlt hlb - } - vl { - lappend blims vll vlr - } - default { - lappend blims $lim - } - } - } - set blims [lsort -unique $blims] - } - } - tcl::dict::set o_opts_table_effective -framelimits_body $blims - switch -- $requested_hlims { - "default" { - set hlims $default_hlims - } - default { - #set hlims $requested_hlims - set hlims [list] - foreach lim $requested_hlims { - switch -- $lim { - hl { - lappend hlims hlt hlb - } - vl { - lappend hlims vll vlr - } - default { - lappend hlims $lim - } - } - } - set hlims [lsort -unique $hlims] - } - } - tcl::dict::set o_opts_table_effective -framelimits_header $hlims - return [tcl::dict::create body $blims header $hlims] - } - method configure args { - if {![llength $args]} { - return $o_opts_table - } - if {[llength $args] == 1} { - if {[lindex $args 0] in [list %topt_keys%]} { - #query single option - set k [lindex $args 0] - set val [tcl::dict::get $o_opts_table $k] - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - set infodict [tcl::dict::create] - switch -- $k { - -ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder_body - -ansiborder_footer { - tcl::dict::set infodict debug [ansistring VIEW $val] - } - -framemap_body - -framemap_header - -framelimits_body - -framelimits_header { - tcl::dict::set returndict effective [tcl::dict::get $o_opts_table_effective $k] - } - } - tcl::dict::set returndict info $infodict - return $returndict - #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] - } else { - error "textblock::table configure - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_table_defaults]" - } - } - if {[llength $args] %2 != 0} { - error "[tcl::namespace::current]::table configure - unexpected argument count. Require name value pairs" - } - foreach {k v} $args { - switch -- $k { - %topt_switchkeys% {} - default { - error "[tcl::namespace::current]::table configure - unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" - } - } - #if {$k ni [tcl::dict::keys $o_opts_table_defaults]} { - # error "[tcl::namespace::current]::table configure - unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" - #} - } - set checked_opts [list] - foreach {k v} $args { - switch -- $k { - -ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder-body - -ansiborder_footer { - set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set ansi_codes [list] ; - foreach {pt code} $parts { - if {$pt ne ""} { - #we don't expect plaintext in an ansibase - error "Unable to interpret $k value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" - } - if {$code ne ""} { - lappend ansi_codes $code - } - } - set ansival [punk::ansi::codetype::sgr_merge_singles $ansi_codes] - lappend checked_opts $k $ansival - } - -frametype - -frametype_header - -frametype_body { - #frametype will raise an error if v is not a valid custom dict or one of the known predefined types such as light,heavy,double etc - lassign [textblock::frametype $v] _cat category _type ftype - lappend checked_opts $k $v - } - -framemap_body - -framemap_header { - #upvar ::textblock::class::opts_table_defaults tdefaults - #set default_bmap [tcl::dict::get $tdefaults -framemap_body] - #todo - check keys and map - if {[llength $v] == 1} { - if {$v eq "default"} { - upvar ::textblock::class::opts_table_defaults tdefaults - set default_map [tcl::dict::get $tdefaults $k] - lappend checked_opts $k $default_map - } else { - error "textblock::table::configure invalid $k value $v. Expected the value 'default' or a dict e.g topleft {hl *}" - } - } else { - #safe jumptable test - #dict for {subk subv} $v {} - foreach {subk subv} $v { - switch -- $subk { - topleft - topinner - topright - topsolo - middleleft - middleinner - middleright - middlesolo - bottomleft - bottominner - bottomright - bottomsolo - onlyleft - onlyinner - onlyright - onlysolo {} - default { - error "textblock::table::configure invalid $subk. Known values {topleft topinner topright topsolo middleleft middleinner middleright middlesolo bottomleft bottominner bottomright bottomsolo onlyleft onlyinner onlyright onlysolo}" - } - } - #safe jumptable test - #dict for {seg subst} $subv {} - foreach {seg subst} $subv { - switch -- $seg { - hl - hlt - hlb - vl - vll - vlr - trc - tlc - blc - brc {} - default { - error "textblock::table::configure invalid $subk value $seg. Known values {hl hlt hlb vl vll vlr trc tlc blc brc}" - } - } - } - - } - lappend checked_opts $k $v - } - - } - -framelimits_body - -framelimits_header { - set specific_framelimits [list] - foreach fl $v { - switch -- $fl { - "default" { - lappend specific_framelimits trc hlt tlc vll blc hlb brc vlr - } - hl { - lappend specific_framelimits hlt hlb - } - vl { - lappend specific_framelimits vll vlr - } - hlt - hlb - vll - vlr - trc - tlc - blc - brc { - lappend specific_framelimits $fl - } - default { - error "textblock::table::configure invalid $k '$fl'. Known values {hl hlb hlt vl vll vlr trc tlc blc brc} (or default for all)" - } - } - } - lappend checked_opts $k $specific_framelimits - } - -ansireset { - if {$v eq "\uFFEF"} { - set RST "\x1b\[m" ;#[a] - lappend checked_opts $k $RST - } else { - error "textblock::table::configure -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" - } - } - -show_hseps { - if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" - } - lappend checked_opts $k $v - #these don't affect column width calculations - } - -show_edge { - if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" - } - lappend checked_opts $k $v - #these don't affect column width calculations - except if table -minwidth/-maxwidth come into play - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - } - -show_vseps { - #we allow empty string - so don't use -strict boolean check - if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" - } - #affects width calculations - set o_calculated_column_widths [list] - lappend checked_opts $k $v - } - -minwidth - -maxwidth { - set o_calculated_column_widths [list] - lappend checked_opts $k $v - } - default { - lappend checked_opts $k $v - } - } - } - #all options checked - ok to update o_opts_table and o_opts_table_effective - - #set o_opts_table [tcl::dict::merge $o_opts_table $checked_opts] - foreach {k v} $args { - switch -- $k { - -framemap_header - -framemap_body { - #framemaps don't require setting every key to update. - #e.g configure -framemaps {topleft } - #needs to merge with existing unspecified keys such as topright middleleft etc. - if {$v eq "default"} { - tcl::dict::set o_opts_table $k default - } else { - if {[tcl::dict::get $o_opts_table $k] eq "default"} { - tcl::dict::set o_opts_table $k $v - } else { - tcl::dict::set o_opts_table $k [tcl::dict::merge [tcl::dict::get $o_opts_table $k] $v] - } - } - } - default { - tcl::dict::set o_opts_table $k $v - } - } - } - #use values from checked_opts for the effective opts - #safe jumptable test - #dict for {k v} $checked_opts {} - #foreach {k v} $checked_opts {} - tcl::dict::for {k v} $checked_opts { - switch -- $k { - -framemap_body - -framemap_header { - set existing [tcl::dict::get $o_opts_table_effective $k] - #set updated $existing - #dict for {subk subv} $v { - # tcl::dict::set updated $subk $subv - #} - #tcl::dict::set o_opts_table_effective $k $updated - tcl::dict::set o_opts_table_effective $k [tcl::dict::merge $existing $v] - } - -framelimits_body - -framelimits_header { - #my Set_effective_framelimits - tcl::dict::set o_opts_table_effective $k $v - } - default { - tcl::dict::set o_opts_table_effective $k $v - } - } - } - #ansireset exception - tcl::dict::set o_opts_table -ansireset [tcl::dict::get $o_opts_table_effective -ansireset] - return $o_opts_table - } - - #integrate with struct::matrix - allows ::m format 2string $table - method printmatrix {matrix} { - set matrix_rowcount [$matrix rows] - set matrix_colcount [$matrix columns] - set table_colcount [my column_count] - if {$table_colcount == 0} { - for {set c 0} {$c < $matrix_colcount} {incr c} { - my add_column -headers "" - } - } - set table_colcount [my column_count] - if {$table_colcount != $matrix_colcount} { - error "textblock::table::printmatrix column count of table doesn't match column count of matrix" - } - if {[my row_count] > 0} { - my row_clear - } - for {set r 0} {$r < $matrix_rowcount} {incr r} { - my add_row [$matrix get row $r] - } - my print - } - method as_matrix {{cmd ""}} { - if {$cmd eq ""} { - set m [struct::matrix] - } else { - set m [struct::matrix $cmd] - } - $m add columns [tcl::dict::size $o_columndata] - $m add rows [tcl::dict::size $o_rowdefs] - tcl::dict::for {k v} $o_columndata { - $m set column $k $v - } - return $m - } - method add_column {args} { - #*** !doctools - #[call class::table [method add_column] [arg args]] - - - if {[llength $args] %2 != 0} { - error "[tcl::namespace::current]::table::add_column unexpected argument count. Require name value pairs. Known options: %copt_keys%" - } - set opts $o_opts_column_defaults - foreach {k v} $args { - switch -- $k { - %copt_switchkeys% { - tcl::dict::set opts $k $v - } - default { - error "[tcl::namespace::current]::table::add_column unknown option '$k'. Known options: %copt_keys%" - } - } - } - set colcount [tcl::dict::size $o_columndefs] - - - tcl::dict::set o_columndata $colcount [list] - #tcl::dict::set o_columndefs $colcount $defaults ;#ensure record exists - tcl::dict::set o_columndefs $colcount $o_opts_column_defaults ;#ensure record exists - - - tcl::dict::set o_columnstates $colcount [tcl::dict::create minwidthbodyseen 0 maxwidthbodyseen 0 maxwidthheaderseen 0] - set prev_calculated_column_widths $o_calculated_column_widths - if {[catch { - my configure_column $colcount {*}$opts - } errMsg]} { - #configure failed - ensure o_columndata and o_columndefs entries are removed - tcl::dict::unset o_columndata $colcount - tcl::dict::unset o_columndefs $colcount - tcl::dict::unset o_columnstates $colcount - #undo cache invalidation - set o_calculated_column_widths $prev_calculated_column_widths - error "add_column failed to configure with supplied options $opts. Err:\n$errMsg" - } - #any add_column that succeeds should invalidate the calculated column widths - set o_calculated_column_widths [list] - set numrows [my row_count] - if {$numrows > 0} { - #fill column with default values - #puts ">>> adding default values for column $colcount" - set dval [tcl::dict::get $opts -defaultvalue] - set width [textblock::width $dval] - tcl::dict::set o_columndata $colcount [lrepeat $numrows $dval] - tcl::dict::set o_columnstates $colcount maxwidthbodyseen $width - tcl::dict::set o_columnstates $colcount minwidthbodyseen $width - } - return $colcount - } - method column_count {} { - return [tcl::dict::size $o_columndefs] - } - method configure_column {index_expression args} { - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - error "textblock::table::configure_column - no column defined at index '$cidx'.Use add_column to define columns" - } - if {![llength $args]} { - return [tcl::dict::get $o_columndefs $cidx] - } else { - if {[llength $args] == 1} { - if {[lindex $args 0] in [list %copt_keys%]} { - #query single option - set k [lindex $args 0] - set val [tcl::dict::get $o_columndefs $cidx $k] - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - set infodict [tcl::dict::create] - switch -- $k { - -ansibase { - tcl::dict::set infodict debug [ansistring VIEW $val] - } - } - tcl::dict::set returndict info $infodict - return $returndict - } else { - error "textblock::table configure_column - unrecognised option '[lindex $args 0]'. Known values %copt_keys%" - } - } - if {[llength $args] %2 != 0} { - error "textblock::table configure_column unexpected argument count. Require name value pairs. Known options: %copt_keys%" - } - foreach {k v} $args { - switch -- $k { - %copt_switchkeys% {} - default { - error "[tcl::namespace::current]::table configure_column unknown option '$k'. Known options: %copt_keys%" - } - } - } - set checked_opts [tcl::dict::get $o_columndefs $cidx] ;#copy of current state - - set hstates $o_headerstates ;#operate on a copy - set colstate [tcl::dict::get $o_columnstates $cidx] - set args_got_headers 0 - set args_got_header_colspans 0 - foreach {k v} $args { - switch -- $k { - -headers { - set args_got_headers 1 - set i 0 - set maxseen 0 ;#don't compare with cached colstate maxwidthheaderseen - we have all the headers for the column right here and need to refresh the colstate maxwidthheaderseen values completely. - foreach hdr $v { - set currentmax [my header_height_calc $i $cidx] ;#exclude current column - ie look at heights for this header in all other columns - #set this_header_height [textblock::height $hdr] - lassign [textblock::size $hdr] _w this_header_width _h this_header_height - - if {$this_header_height >= $currentmax} { - tcl::dict::set hstates $i maxheightseen $this_header_height - } else { - tcl::dict::set hstates $i maxheightseen $currentmax - } - if {$this_header_width >= $maxseen} { - set maxseen $this_header_width - } - #if {$this_header_width > [tcl::dict::get $colstate maxwidthheaderseen]} { - # tcl::dict::set colstate maxwidthheaderseen $this_header_width - #} - incr i - } - tcl::dict::set colstate maxwidthheaderseen $maxseen - #review - we could avoid some recalcs if we check current width range compared to previous - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - tcl::dict::set checked_opts $k $v - } - -header_colspans { - 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 '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]} { - error "configure_column $cidx -header_colspans. Only [tcl::dict::size $cspans] headers exist. Too many values supplied" - } - foreach s $v { - 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 'any' or a positive integer" - } - } else { - 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 "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 "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 "any"} { - set remaining "any" - } else { - if {$remaining eq "any"} { - if {$span ne "0"} { - #a previous column has ended the 'any' span - set remaining [expr {$span -1}] - } - } else { - if {$span eq "0"} { - incr remaining -1 - } else { - set remaining [expr {$span -1}] - } - #allow to go negative - } - } - } - if {$remaining eq "any"} { - #any int >0 ok - what about 'any' immediately following any? - } else { - if {$remaining > 0} { - if {$s ne "0" && $s ne ""} { - error "configure_column $cidx -header_colspans bad span $s for header '$h'. Remaining span is '$remaining' - so a zero colspan is required" - } - } else { - if {$s == 0} { - error "configure_column $cidx -header_colspans bad span $s for header '$h'. No span in place - need >=1 or 'any'" - } - } - } - #} - } - incr h - } - #todo - avoid recalc if no change - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - tcl::dict::set checked_opts $k $v - } - -minwidth { - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - tcl::dict::set checked_opts $k $v - } - -maxwidth { - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - tcl::dict::set checked_opts $k $v - } - -ansibase { - set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set col_ansibase_items [list] ; - foreach {pt code} $parts { - if {$pt ne ""} { - #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" - } - if {$code ne ""} { - lappend col_ansibase_items $code - } - } - set col_ansibase [punk::ansi::codetype::sgr_merge_singles $col_ansibase_items] - tcl::dict::set checked_opts $k $col_ansibase - } - -ansireset { - if {$v eq "\uFFEF"} { - tcl::dict::set checked_opts $k "\x1b\[m" ;# [a] - } else { - error "textblock::table::configure_column -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" - } - } - -blockalign - -textalign { - switch -- $v { - left - right { - tcl::dict::set checked_opts $k $v - } - centre - centre { - tcl::dict::set checked_opts $k centre - } - } - } - default { - tcl::dict::set checked_opts $k $v - } - } - } - #args checked - ok to update headerstates and columndefs and columnstates - tcl::dict::set o_columndefs $cidx $checked_opts - - set o_headerstates $hstates - tcl::dict::set o_columnstates $cidx $colstate - - if {$args_got_headers} { - #if the headerlist length for this column has shrunk,and it was the longest - we may now have excess entries in o_headerstates - set zero_heights [list] - tcl::dict::for {hidx _v} $o_headerstates { - #pass empty string for exclude_column so we don't exclude our own column - if {[my header_height_calc $hidx ""] == 0} { - lappend zero_heights $hidx - } - } - foreach zidx $zero_heights { - tcl::dict::unset o_headerstates $zidx - } - } - if {$args_got_headers || $args_got_header_colspans} { - #check and adjust header_colspans for all columns - - } - - return [tcl::dict::get $o_columndefs $cidx] - } - } - - method header_count {} { - return [tcl::dict::size $o_headerstates] - } - method header_count_calc {} { - set max_headers 0 - tcl::dict::for {k cdef} $o_columndefs { - set num_headers [llength [tcl::dict::get $cdef -headers]] - set max_headers [expr {max($max_headers,$num_headers)}] - } - return $max_headers - } - method header_height {header_index} { - set idx [lindex [tcl::dict::keys $o_headerstates $header_index]] - return [tcl::dict::get $o_headerstates $idx maxheightseen] - } - - #review - use maxwidth (considering colspans) of each column to determine height after wrapping - # -need to consider whether vertical expansion allowed / maxheight? - method header_height_calc {header_index {exclude_column ""}} { - set dataheight 0 - if {$exclude_column eq ""} { - set exclude_colidx "" - } else { - set exclude_colidx [lindex [tcl::dict::keys $o_columndefs] $exclude_column] - } - tcl::dict::for {cidx cdef} $o_columndefs { - if {$exclude_colidx == $cidx} { - continue - } - set headerlist [tcl::dict::get $cdef -headers] - if {$header_index < [llength $headerlist]} { - set this_height [textblock::height [lindex $headerlist $header_index]] - set dataheight [expr {max($dataheight,$this_height)}] - } - } - return $dataheight - } - - #return a dict keyed on header index with values representing colspans - #e.g - # 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] - set colspans_by_header [tcl::dict::create] - tcl::dict::for {cidx cdef} $o_columndefs { - set headerlist [tcl::dict::get $cdef -headers] - set colspans_for_column [tcl::dict::get $cdef -header_colspans] - for {set h 0} {$h < $num_headers} {incr h} { - set headerspans [punk::lib::dict_getdef $colspans_by_header $h [list]] - set defined_span [lindex $colspans_for_column $h] - set i 0 - set spanremaining [lindex $headerspans 0] - if {$spanremaining ne "any"} { - if {$spanremaining eq ""} { - set spanremaining 1 - } - incr spanremaining -1 - } - foreach s $headerspans { - if {$s eq "any"} { - set spanremaining "any" - } elseif {$s == 0} { - if {$spanremaining ne "any"} { - incr spanremaining -1 - } - } else { - set spanremaining [expr {$s - 1}] - } - incr i - } - if {$defined_span eq ""} { - if {$spanremaining eq "0"} { - lappend headerspans 1 - } else { - #"any" or an integer - lappend headerspans 0 - } - } else { - lappend headerspans $defined_span - } - tcl::dict::set colspans_by_header $h $headerspans - } - } - 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. - #It can also be set column by column - but it is much easier (especially for colspans) to configure them on a header-row basis - #e.g o_headerstates: 0 {maxheightseen 1} 1 {maxheightseen 2} - set num_headers [my header_count_calc] - set hidx [lindex [tcl::dict::keys $o_headerstates] $index_expression] - if {$hidx eq ""} { - error "textblock::table::configure_header - no row defined at index '$hidx'." - } - if {$hidx > $num_headers -1} { - #assert - shouldn't happen - error "textblock::table::configure_header error headerstates data is out of sync" - } - - if {![llength $args]} { - set colspans_by_header [my header_colspans] - set result [tcl::dict::create] - tcl::dict::set result -colspans [tcl::dict::get $colspans_by_header $hidx] - set header_row_items [list] - tcl::dict::for {cidx cdef} $o_columndefs { - set colheaders [tcl::dict::get $cdef -headers] - set relevant_header [lindex $colheaders $hidx] - #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns - lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. - } - tcl::dict::set result -values $header_row_items - return $result - } - if {[llength $args] == 1} { - if {[lindex $args 0] in [tcl::dict::keys $o_opts_header_defaults]} { - #query single option - set k [lindex $args 0] - #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] - tcl::dict::for {cidx cdef} $o_columndefs { - set colheaders [tcl::dict::get $cdef -headers] - set relevant_header [lindex $colheaders $hidx] - #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns - lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. - - } - set val $header_row_items - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - } - -colspans { - set colspans_by_header [my header_colspans] - set result [tcl::dict::create] - set val [tcl::dict::get $colspans_by_header $hidx] - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - } - -ansibase { - set val ??? - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - tcl::dict::set infodict debug [ansistring VIEW $val] - } - } - tcl::dict::set returndict info $infodict - return $returndict - #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] - } else { - error "textblock::table configure_header - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_header_defaults]" - } - } - if {[llength $args] %2 != 0} { - error "textblock::table configure_header incorrect number of options following index_expression. Require name value pairs. Known options: [tcl::dict::keys $o_opts_header_defaults]" - } - foreach {k v} $args { - if {$k ni [tcl::dict::keys $o_opts_header_defaults]} { - error "[tcl::namespace::current]::table configure_row unknown option '$k'. Known options: [tcl::dict::keys $o_opts_header_defaults]" - } - } - - set checked_opts [list] - #safe jumptable test - #dict for {k v} $args {} - foreach {k v} $args { - switch -- $k { - -ansibase { - set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set header_ansibase_items [list] ; - foreach {pt code} $parts { - if {$pt ne ""} { - #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" - } - if {$code ne ""} { - lappend header_ansibase_items $code - } - } - set header_ansibase [punk::ansi::codetype::sgr_merge_singles $row_ansibase_items] - error "sorry - -ansibase not yet implemented for header rows" - lappend checked_opts $k $header_ansibase - } - -ansireset { - if {$v eq "\uFFEF"} { - lappend checked_opts $k "\x1b\[m" ;# [a] - } else { - error "textblock::table::configure_header -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" - } - } - -values { - if {[llength $v] > [tcl::dict::size $o_columndefs]} { - error "textblock::table::configure_header -values length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])" - } - lappend checked_opts $k $v - } - -colspans { - set numcols [tcl::dict::size $o_columndefs] - if {[llength $v] > $numcols} { - error "textblock::table::configure_header -colspans length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])" - } - if {[llength $v] < $numcols} { - puts stderr "textblock::table::configure_header warning - only [llength $v] spans specified for [tcl::dict::size $o_columndefs] columns." - puts stderr "It is recommended to set all spans explicitly. (auto-calc not implemented)" - } - if {[llength $v]} { - set firstspan [lindex $v 0] - set first_is_ok 0 - 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 \"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 "any"} { - incr remaining -1 - } - set spanview $v - set sidx 1 - #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 "any"} { - if {$span eq "any"} { - set remaining "any" - } elseif {$span > 0} { - #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 \"any\".[a] $spanview" - } - set remaining $span - incr remaining -1 - } else { - #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 \"any\" value.[a] $spanview" - } else { - incr remaining -1 - } - } else { - if {$remaining eq "0"} { - #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 \"any\".[a] $spanview" - } - set remaining $span - if {$remaining ne "any"} { - incr remaining -1 - } - } else { - lset spanview $sidx [a+ web-red]$span[a] - error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require zero value span.[a] $spanview" - } - } - } - incr sidx - } - } - #empty -colspans list should be ok - - #error "sorry - -colspans not yet implemented for header rows - set manually in vertical order via configure_column for now" - lappend checked_opts $k $v - } - default { - lappend checked_opts $k $v - } - } - } - - #configured opts all good - #safe jumptable test - #dict for {k v} $checked_opts {} - #foreach {k v} $checked_opts {} - tcl::dict::for {k v} $checked_opts { - switch -- $k { - -values { - set c 0 - foreach hval $v { - #retrieve -headers from relevant col, insert at header index, and write back. - set thiscol_headers_vertical [tcl::dict::get $o_columndefs $c -headers] - set missing [expr {($hidx +1) - [llength $thiscol_headers_vertical]}] - if {$missing > 0} { - lappend thiscol_headers_vertical {*}[lrepeat $missing ""] - } - lset thiscol_headers_vertical $hidx $hval - tcl::dict::set o_columndefs $c -headers $thiscol_headers_vertical - #invalidate column width cache - set o_calculated_column_widths [list] - # -- -- -- -- -- -- - #also update maxwidthseen & maxheightseen - set i 0 - set maxwidthseen 0 - #set maxheightseen 0 - foreach hdr $thiscol_headers_vertical { - lassign [textblock::size $hdr] _w this_header_width _h this_header_height - set maxheightseen [punk::lib::dict_getdef $o_headerstates $i maxheightseen 0] - if {$this_header_height >= $maxheightseen} { - tcl::dict::set o_headerstates $i maxheightseen $this_header_height - } else { - tcl::dict::set o_headerstates $i maxheightseen $maxheightseen - } - if {$this_header_width >= $maxwidthseen} { - set maxwidthseen $this_header_width - } - incr i - } - tcl::dict::set o_columnstates $c maxwidthheaderseen $maxwidthseen - # -- -- -- -- -- -- - incr c - } - } - -colspans { - #sequence has been verified above - we need to split it and store across columns - set c 0 ;#column index - foreach span $v { - set colspans [tcl::dict::get $o_columndefs $c -header_colspans] - if {$hidx > [llength $colspans]-1} { - set colspans_by_header [my header_colspans] - #puts ">>>>>?$colspans_by_header" - #we are allowed to lset only one beyond the current length to append - #but there may be even less or no entries present in a column - # - the ability to underspecify and calculate the missing values makes setting the values complicated. - #use the header_colspans calculation to update only those entries necessary - set spanlist [list] - for {set h 0} {$h < $hidx} {incr h} { - set cspans [tcl::dict::get $colspans_by_header $h] - set requiredval [lindex $cspans $c] - lappend spanlist $requiredval - } - tcl::dict::set o_columndefs $c -header_colspans $spanlist - - set colspans [tcl::dict::get $o_columndefs $c -header_colspans] - } - - lset colspans $hidx $span - tcl::dict::set o_columndefs $c -header_colspans $colspans - incr c - } - } - } - } - } - - method add_row {valuelist args} { - #*** !doctools - #[call class::table [method add_row] [arg args]] - if {[tcl::dict::size $o_columndefs] > 0 && ([llength $valuelist] && [llength $valuelist] != [tcl::dict::size $o_columndefs])} { - set msg "" - append msg "add_row - invalid number ([llength $valuelist]) of values in row - Must match existing column count: [tcl::dict::size $o_columndefs]" \n - append msg "rowdata: $valuelist" - error $msg - } - if {[tcl::dict::size $o_columndefs] == 0 && ![llength $valuelist]} { - error "add_row - no values supplied, and no columns defined, so cannot use default column values" - } - - set defaults [tcl::dict::create\ - -minheight 1\ - -maxheight ""\ - -ansibase ""\ - -ansireset "\uFFEF"\ - ] - set o_opts_row_defaults $defaults - - if {[llength $args] %2 !=0} { - error "[tcl::namespace::current]::table::add_row unexpected argument count. Require name value pairs. Known options: [tcl::dict::keys $defaults]" - } - #safe jumptable test - #dict for {k v} $args {} - foreach {k v} $args { - switch -- $k { - -minheight - -maxheight - -ansibase - -ansireset {} - default { - error "Invalid option '$k' Known options: [tcl::dict::keys $defaults] (-ansireset is read-only)" - } - } - } - set opts [tcl::dict::merge $defaults $args] - - set auto_columns 0 - if {[tcl::dict::size $o_columndefs] == 0} { - set auto_columns 1 - #no columns defined - auto define with defaults for each column in first supplied row - #auto define columns only valid if no existing columns - #the autocolumns must be added before configure_row - but if configure_row fails - we need to remove them! - foreach el $valuelist { - my add_column - } - } else { - if {![llength $valuelist]} { - tcl::dict::for {k coldef} $o_columndefs { - lappend valuelist [tcl::dict::get $coldef -defaultvalue] - } - } - } - set rowcount [tcl::dict::size $o_rowdefs] - tcl::dict::set o_rowdefs $rowcount $defaults ;# ensure record exists before configure - - if {[catch { - my configure_row $rowcount {*}$opts - } errMsg]} { - #undo anything we saved before configure_row - tcl::dict::unset o_rowdefs $rowcount - #remove auto_columns - if {$auto_columns} { - set o_columndata [tcl::dict::create] - set o_columndefs [tcl::dict::create] - set o_columnstate [tcl::dict::create] - } - error "add_row failed to configure with supplied options $opts. Err:\n$errMsg" - } - - - set c 0 - set max_height_seen 1 - foreach v $valuelist { - set prev_maxwidth [tcl::dict::get $o_columnstates $c maxwidthbodyseen] - set prev_minwidth [tcl::dict::get $o_columnstates $c minwidthbodyseen] - - tcl::dict::lappend o_columndata $c $v - set valheight [textblock::height $v] - if {$valheight > $max_height_seen} { - set max_height_seen $valheight - } - set width [textblock::width $v] - if {$width > [tcl::dict::get $o_columnstates $c maxwidthbodyseen]} { - tcl::dict::set o_columnstates $c maxwidthbodyseen $width - } - if {$width < [tcl::dict::get $o_columnstates $c minwidthbodyseen]} { - tcl::dict::set o_columnstates $c minwidthbodyseen $width - } - - if {[tcl::dict::get $o_columnstates $c maxwidthbodyseen] > $prev_maxwidth || [tcl::dict::get $o_columnstates $c minwidthbodyseen] < $prev_minwidth} { - #invalidate calculated column width cache if any new value was outside the previous range of widths - set o_calculated_column_widths [list] - } - incr c - } - - set opt_maxh [tcl::dict::get $o_rowdefs $rowcount -maxheight] - if {$opt_maxh ne ""} { - tcl::dict::set o_rowstates $rowcount -maxheight [expr {min($opt_maxh,$max_height_seen)}] - } else { - tcl::dict::set o_rowstates $rowcount -maxheight $max_height_seen - } - - return $rowcount - } - method configure_row {index_expression args} { - set ridx [lindex [tcl::dict::keys $o_rowdefs] $index_expression] - if {$ridx eq ""} { - error "textblock::table::configure_row - no row defined at index '$ridx'.Use add_row to define rows" - } - if {![llength $args]} { - return [tcl::dict::get $o_rowdefs $ridx] - } - if {[llength $args] == 1} { - if {[lindex $args 0] in [tcl::dict::keys $o_opts_row_defaults]} { - #query single option - set k [lindex $args 0] - set val [tcl::dict::get $o_rowdefs $ridx $k] - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - set infodict [tcl::dict::create] - switch -- $k { - -ansibase { - tcl::dict::set infodict debug [ansistring VIEW $val] - } - } - tcl::dict::set returndict info $infodict - return $returndict - #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] - } else { - error "textblock::table configure_row - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_row_defaults]" - } - } - if {[llength $args] %2 != 0} { - error "textblock::table configure_row incorrect number of options following index_expression. Require name value pairs. Known options: [tcl::dict::keys $o_opts_row_defaults]" - } - foreach {k v} $args { - if {$k ni [tcl::dict::keys $o_opts_row_defaults]} { - error "[tcl::namespace::current]::table configure_row unknown option '$k'. Known options: [tcl::dict::keys $o_opts_row_defaults]" - } - } - set checked_opts [list] - foreach {k v} $args { - switch -- $k { - -ansibase { - set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set row_ansibase_items [list] ; - foreach {pt code} $parts { - if {$pt ne ""} { - #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" - } - if {$code ne ""} { - lappend row_ansibase_items $code - } - } - set row_ansibase [punk::ansi::codetype::sgr_merge_singles $row_ansibase_items] - lappend checked_opts $k $row_ansibase - } - -ansireset { - if {$v eq "\uFFEF"} { - lappend checked_opts $k "\x1b\[m" ;# [a] - } else { - error "textblock::table::configure_row -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" - } - } - default { - lappend checked_opts $k $v - } - } - } - - set current_opts [tcl::dict::get $o_rowdefs $ridx] - set opts [tcl::dict::merge $current_opts $checked_opts] - - #check minheight and maxheight together - set opt_minh [tcl::dict::get $opts -minheight] - set opt_maxh [tcl::dict::get $opts -maxheight] - - #todo - allow zero values to hide/collapse rows as is possible with columns - if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} { - error "[tcl::namespace::current]::table::configure_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)" - } - if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} { - error "[tcl::namespace::current]::table::configure_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)" - } - if {$opt_maxh ne "" && $opt_maxh < $opt_minh} { - error "[tcl::namespace::current]::table::configure_row error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'" - } - tcl::dict::set o_rowstates $ridx -minheight $opt_minh - - - tcl::dict::set o_rowdefs $ridx $opts - } - method row_count {} { - return [tcl::dict::size $o_rowdefs] - } - method row_clear {} { - set o_rowdefs [tcl::dict::create] - set o_rowstates [tcl::dict::create] - #The data values are stored by column regardless of whether added row by row - tcl::dict::for {cidx records} $o_columndata { - tcl::dict::set o_columndata $cidx [list] - #reset only the body fields in o_columnstates - tcl::dict::set o_columnstates $cidx minwidthbodyseen 0 - tcl::dict::set o_columnstates $cidx maxwidthbodyseen 0 - } - set o_calculated_column_widths [list] - } - method clear {} { - my row_clear - set o_columndefs [tcl::dict::create] - set o_columndata [tcl::dict::create] - set o_columnstates [tcl::dict::create] - } - - - - #method Get_columns_by_name {namematch_list} { - #} - - #specify range with x..y - method Get_columns_by_indices {index_list} { - foreach spec $index_list { - if {[tcl::string::is integer -strict $c]} { - set colidx $c - } else { - tcl::dict::for {colidx coldef} $o_columndefs { - #if {[tcl::string::match x x]} {} - } - } - } - } - method Get_boxlimits_and_joins {position fname_body} { - #fname_body will be "custom" or one of the predefined types light,heavy etc - switch -- $position { - left { - return [tcl::dict::create \ - boxlimits [list hlb blc vll]\ - boxlimits_top [list hlb blc vll hlt tlc]\ - joins [list down]\ - bodyjoins [list down-$fname_body]\ - ] - } - inner { - return [tcl::dict::create \ - boxlimits [list hlb blc vll]\ - boxlimits_top [list hlb blc vll hlt tlc]\ - joins [list down left]\ - bodyjoins [list left down-$fname_body] - ] - } - right { - return [tcl::dict::create \ - boxlimits [list hlb blc vll vlr brc]\ - boxlimits_top [list hlb blc vll vlr brc hlt tlc trc]\ - joins [list down left]\ - bodyjoins [list left down-$fname_body]\ - ] - } - solo { - return [tcl::dict::create \ - boxlimits [list hlb blc vll vlr brc]\ - boxlimits_top [list hlb blc vll vlr brc hlt tlc trc]\ - joins [list down]\ - bodyjoins [list down-$fname_body]\ - ] - } - default { - error "Get_boxlimits_and_joins unrecognised position '$position' expected: left inner right solo" - } - } - } - method Get_boxlimits_and_joins1 {position fname_body} { - #fname_body will be "custom" or one of the predefined types light,heavy etc - switch -- $position { - left { - #set header_boxlimits {hlb hlt tlc blc vll} - set header_body_joins [list down-$fname_body] - set boxlimits_position [list hlb blc vll] - #set boxlimits_toprow [concat $boxlimits_position {hlt tlc}] - set boxlimits_toprow [list hlb blc vll hlt tlc] - set joins [list down] - } - inner { - #set header_boxlimits {hlb hlt tlc blc vll} - set header_body_joins [list left down-$fname_body] - set boxlimits_position [list hlb blc vll] - #set boxlimits_toprow [concat $boxlimits_position {hlt tlc}] - set boxlimits_toprow [list hlb blc vll hlt tlc] - set joins [list down left] - } - right { - #set header_boxlimits {hlb hlt tlc blc vll vlr trc brc} - set header_body_joins [list left down-$fname_body] - set boxlimits_position [list hlb blc vll vlr brc] - #set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}] - set boxlimits_toprow [list hlb blc vll vlr brc hlt tlc trc] - set joins [list down left] - } - solo { - #set header_boxlimits {hlb hlt tlc blc vll vlr trc brc} - set header_body_joins [list down-$fname_body] - set boxlimits_position [list hlb blc vll vlr brc] - #set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}] - set boxlimits_toprow [list hlb blc vll vlr brc hlt tlc trc] - set joins [list down] - } - } - return [tcl::dict::create boxlimits $boxlimits_position boxlimits_top $boxlimits_toprow joins $joins bodyjoins $header_body_joins ] - } - method get_column_by_index {index_expression args} { - #puts "+++> get_column_by_index $index_expression $args [tcl::namespace::current]" - #index_expression may be something like end-1 or 2+2 - we can't directly use it as a lookup for dicts. - set opts [tcl::dict::create\ - -position "inner"\ - -return "string"\ - ] - foreach {k v} $args { - switch -- $k { - -position - -return { - tcl::dict::set opts $k $v - } - default { - error "[tcl::namespace::current]::table::get_column_by_index error invalid option '$k'. Known options [tcl::dict::keys $opts]" - } - } - } - set opt_posn [tcl::dict::get $opts -position] - set opt_return [tcl::dict::get $opts -return] - - switch -- $opt_posn { - left - inner - right - solo {} - default { - error "[tcl::namespace::current]::table::get_column_by_index error invalid value '$opt_posn' for -position. Valid values: [list left inner right solo]" - } - } - switch -- $opt_return { - string - dict {} - default { - error "[tcl::namespace::current]::table::get_column_by_index error invalid value '$opt_return' for -return. Valid values: string dict" - } - } - - set columninfo [my get_column_cells_by_index $index_expression] - set header_list [tcl::dict::get $columninfo headers] - #puts "===== header_list: $header_list" - set cells [tcl::dict::get $columninfo cells] - - set topt_show_header [tcl::dict::get $o_opts_table -show_header] - if {$topt_show_header eq ""} { - set allheaders 0 - set all_cols [tcl::dict::keys $o_columndefs] - foreach c $all_cols { - incr allheaders [llength [tcl::dict::get $o_columndefs $c -headers]] - } - if {$allheaders == 0} { - set do_show_header 0 - } else { - set do_show_header 1 - } - } else { - set do_show_header $topt_show_header - } - set topt_show_footer [tcl::dict::get $o_opts_table -show_footer] - - - set output "" - set part_header "" - set part_body "" - set part_footer "" - - set boxlimits "" - set joins "" - set header_boxlimits [list] - set header_body_joins [list] - - - set ftypes [my Get_frametypes] - set ftype_body [tcl::dict::get $ftypes body] - if {[llength $ftype_body] >= 2} { - set fname_body "custom" - } else { - set fname_body $ftype_body - } - set ftype_header [tcl::dict::get $ftypes header] - if {[llength $ftype_header] >= 2} { - set fname_header "custom" - } else { - set fname_header $ftype_header - } - - set limj [my Get_boxlimits_and_joins $opt_posn $fname_body] - set header_body_joins [tcl::dict::get $limj bodyjoins] - set joins [tcl::dict::get $limj joins] - set boxlimits_position [tcl::dict::get $limj boxlimits] - set boxlimits_toprow [tcl::dict::get $limj boxlimits_top] - #use struct::set instead of simple for loop - will be faster at least when critcl available - set boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_position] - set boxlimits_headerless [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_toprow] - set header_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $boxlimits_position] - set header_boxlimits_toprow [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $boxlimits_toprow] - - set fmap [tcl::dict::get $o_opts_table_effective -framemap_body] - set hmap [tcl::dict::get $o_opts_table_effective -framemap_header] - - #if {![tcl::dict::get $o_opts_table -show_edge]} { - # set body_edgemap [textblock::class::table_edge_map ""] - # dict for {k v} $fmap { - # #tcl::dict::set fmap $k [tcl::dict::merge $v [tcl::dict::get $body_edgemap $k]] - # } - # set header_edgemap [textblock::class::header_edge_map ""] - # dict for {k v} $hmap { - # #tcl::dict::set hmap $k [tcl::dict::merge $v [tcl::dict::get $header_edgemap $k]] - # } - #} - set sep_elements_horizontal $::textblock::class::table_hseps - set sep_elements_vertical $::textblock::class::table_vseps - - set topmap [tcl::dict::get $fmap top$opt_posn] - set botmap [tcl::dict::get $fmap bottom$opt_posn] - set midmap [tcl::dict::get $fmap middle$opt_posn] - set onlymap [tcl::dict::get $fmap only$opt_posn] - - set hdrmap [tcl::dict::get $hmap only${opt_posn}] - - set topseps_h [tcl::dict::get $sep_elements_horizontal 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] - - #top should work for all header rows regarding vseps - as we only use it to reduce the box elements, and lower headers have same except for tlc which isn't present anyway - set headerseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] - - lassign [my Get_seps] _h show_seps_h _v show_seps_v - set return_headerheight 0 - set return_headerwidth 0 - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - - set colwidth [my column_width $cidx] - - set col_blockalign [tcl::dict::get $o_columndefs $cidx -blockalign] - - if {$do_show_header} { - #puts "boxlimitsinfo header $opt_posn: -- boxlimits $header_boxlimits -- boxmap $hdrmap" - set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] ;#merged to single during configure - set ansiborder_header [tcl::dict::get $o_opts_table -ansiborder_header] - if {[tcl::dict::get $o_opts_table -frametype_header] eq "block"} { - set extrabg [punk::ansi::codetype::sgr_merge_singles [list $ansibase_header] -filter_fg 1] - set ansiborder_final $ansibase_header$ansiborder_header$extrabg - } else { - set ansiborder_final $ansibase_header$ansiborder_header - } - set RST [punk::ansi::a] - - - set hcolwidth $colwidth - #set hcolwidth [my column_width_configured $cidx] - set hcell_line_blank [tcl::string::repeat " " $hcolwidth] - - 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 span_extend_map [tcl::dict::create \ - vll " "\ - tlc [tcl::dict::get $fdef_header hlt]\ - blc [tcl::dict::get $fdef_header hlb]\ - ] - - - #used for colspan-zero header frames - set framesub_map [list hl $TSUB vll $TSUB vlr $TSUB tlc $TSUB blc $TSUB trc $TSUB brc $TSUB] ;# a debug test - - set hrow 0 - set hmax [expr {[llength $header_list] -1}] - foreach header $header_list { - set headerspans [tcl::dict::get $all_colspans $hrow] - set this_span [lindex $headerspans $cidx] - set hval $ansibase_header$header ;#no reset - set rowh [my header_height $hrow] - - if {$hrow == 0} { - set hlims $header_boxlimits_toprow - set rowpos "top" - if {$hrow == $hmax} { - set rowpos "only" - } - } else { - set hlims $header_boxlimits - set rowpos "middle" - if {$hrow == $hmax} { - set rowpos "bottom" - } - } - if {!$show_seps_v} { - set hlims [struct::set difference $hlims $headerseps_v] - } - if {$hrow == $hmax} { - set header_joins $header_body_joins - } else { - set header_joins $joins - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] - } - #puts ">>> headerspans: $headerspans cidx: $cidx" - - #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} { - if {[tcl::dict::exists $all_colspans [expr {$hrow+1}]]} { - set next_spanlist [tcl::dict::get $all_colspans [expr {$hrow+1}]] - set spanbelow [lindex $next_spanlist $cidx] - if {$spanbelow == 0} { - #we don't want a down-join for blc - use a framedef with only left joins - tcl::dict::set startmap blc [tcl::dict::get $framedef_leftbox blc] - } - } else { - set next_spanlist [list] - } - } - - #supporting wrapping in headers might be a step too difficult for little payoff. - #we would need a flag to enable/disable - plus language-based wrapping alg (see tcllib) - #The interaction with colspans and width calculations makes it likely to have a heavy performance impact and make the code even more complex. - #May be better to require user to pre-wrap as needed - ##set hval [textblock::renderspace -width $colwidth -wrap 1 "" $hval] - - #review - contentwidth of hval can be greater than $colwidth+2 - if so frame function will detect and frame_cache will not be used - #This ellipsis 0 makes a difference (unwanted ellipsis at rhs of header column that starts span) - - # -width is always +2 - as the boxlimits take into account show_vseps and show_edge - #set header_cell_startspan [textblock::frame -ellipsis 0 -usecache 1 -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ - # -ansibase $ansibase_header -ansiborder $ansiborder_final\ - # -boxlimits $hlims -boxmap $startmap -joins $header_joins $hval\ - # ] - - if {$this_span == 1} { - #write the actual value now - set cellcontents $hval - } else { - #just write an empty vertical placeholder. The spanned value will be overtyped below - set cellcontents [::join [lrepeat [llength [split $hval \n]] ""] \n] - } - set header_cell_startspan [textblock::frame -blockalign $col_blockalign -ellipsis 0 -usecache 1 -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ - -ansibase $ansibase_header -ansiborder $ansiborder_final\ - -boxlimits $hlims -boxmap $startmap -joins $header_joins $cellcontents\ - ] - - if {$this_span != 1} { - #puts "===>\n$header_cell_startspan\n<===" - set spanned_parts [list $header_cell_startspan] - #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 ""] - set hcell_blank [::join $h_lines \n] ;#todo - just use -height option of frame? review - currently doesn't cache with -height and no contents - slow - - - - set last [expr {[llength $remaining_spans] -1}] - set i 0 - foreach s $remaining_spans { - if {$s == 0} { - if {$i == $last} { - set next_posn right - #set next_posn inner - } else { - set next_posn inner - } - - set next_headerseps_v [tcl::dict::get $sep_elements_vertical top$next_posn] ;#static top ok - - set limj [my Get_boxlimits_and_joins $next_posn $fname_body] - set span_joins_body [tcl::dict::get $limj bodyjoins] - set span_joins [tcl::dict::get $limj joins] - set span_boxlimits [tcl::dict::get $limj boxlimits] - set span_boxlimits_top [tcl::dict::get $limj boxlimits_top] - #use struct::set instead of simple for loop - will be faster at least when critcl available - #set span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits] - #set span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits_top] - set header_span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $span_boxlimits] - set header_span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $span_boxlimits_top] - if {$hrow == 0} { - set hlims $header_span_boxlimits_top - } else { - set hlims $header_span_boxlimits - } - - set this_span_map $span_extend_map - if {!$show_seps_v} { - set hlims [struct::set difference $hlims $next_headerseps_v] - } else { - if {[llength $next_spanlist]} { - set spanbelow [lindex $next_spanlist $spancol] - if {$spanbelow != 0} { - 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 - 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 - } - } - - if {$hrow == $hmax} { - set header_joins $span_joins_body - } else { - set header_joins $span_joins - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$next_posn] ] - } - - set contentwidth [my column_width $spancol] - set header_cell [textblock::frame -ellipsis 0 -width [expr {$contentwidth + 2}] -type [tcl::dict::get $ftypes header]\ - -ansibase $ansibase_header -ansiborder $ansiborder_final\ - -boxlimits $hlims -boxmap $this_span_map -joins $header_joins $hcell_blank\ - ] - lappend spanned_parts $header_cell - } else { - break - } - incr spancol - incr i - } - - #JMN - #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 {$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 { - 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]} { - 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 - #set spacemap [list hl * vl * tlc * blc * trc * brc *] - #-usecache 1 ok - #hval is not raw headerval - it has been padded to required width and has ansi applied - set hblock [textblock::frame -ellipsis 0 -type $spacemap -boxlimits $hlims -ansibase $ansibase_header $hval] ;#review -ansibase - #puts "==>boxlimits:'$hlims' hval_width:[tcl::string::length $hval] blockwidth:[textblock::width $hblock]" - #puts $hblock - #puts "==>hval:'$hval'[a]" - #puts "==>hval:'[ansistring VIEW $hval]'" - #set spanned_frame [overtype::renderspace -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 - set spanned_frame [textblock::join_basic -- $header_cell_startspan] - } - - - append part_header $spanned_frame - append part_header \n - } else { - #zero span header directly in this column ie one that is being colspanned by some column to our left - #previous col will already have built lines for this in it's own header rhs overhang - #we need a block of TSUB chars of the right height and width in this column so that we can join this column to the left ones with the TSUBs being transparent. - - #set padwidth [my column_datawidth $cidx -headers 0 -data 1 -cached 1] - - #if there are no header elements above then we will need a minimum of the column width - #may be extended to the widest portion of the header in the loop below - set padwidth [my column_width $cidx] - - - #under assumption we are building table using L frame method and that horizontal borders are only ever 1 high - # - we can avoid using a frame - but we potentially need to manually adjust for show_hpos show_edge etc - #avoiding frame here is faster.. but not by much (<10%? on textblock::spantest2 ) - if 0 { - #breaks -show_edge 0 - if {$rowpos eq "top" && [tcl::dict::get $o_opts_table -show_edge]} { - set padheight [expr {$rowh + 2}] - } else { - set padheight [expr {$rowh + 1}] - } - set bline [tcl::string::repeat $TSUB [expr {$padwidth +1}]] - set h_lines [lrepeat $padheight $bline] - set hcell_blank [::join $h_lines \n] - set header_frame $hcell_blank - } else { - set bline [tcl::string::repeat $TSUB $padwidth] - set h_lines [lrepeat $rowh $bline] - set hcell_blank [::join $h_lines \n] - # -usecache 1 ok - #frame borders will never display - so use the simplest frametype and don't apply any ansi - #puts "===>zerospan hlims: $hlims" - set header_frame [textblock::frame -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\ - -boxlimits $hlims -boxmap $framesub_map $hcell_blank\ - ] - } - - append part_header $header_frame\n - - } - incr hrow - } - if {![llength $header_list]} { - #no headers - but we've been asked to show_header - #display a zero content-height header (ie outline if edge is being shown - or bottom bar) - set hlims $header_boxlimits_toprow - if {!$show_seps_v} { - set hlims [struct::set difference $hlims $headerseps_v] - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts only$opt_posn] ] - } - set header_joins $header_body_joins - set header_frame [textblock::frame -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ - -ansibase $ansibase_header -ansiborder $ansiborder_final\ - -boxlimits $hlims -boxmap $hdrmap -joins $header_joins\ - ] - append part_header $header_frame\n - } - set part_header [tcl::string::trimright $part_header \n] - lassign [textblock::size $part_header] _w return_headerwidth _h return_headerheight - - set padline [tcl::string::repeat $TSUB $return_headerwidth] - set adjusted_lines [list] - foreach ln [split $part_header \n] { - if {[tcl::string::first $TSUB $ln] >=0} { - lappend adjusted_lines $padline - } else { - lappend adjusted_lines $ln - } - } - set part_header [::join $adjusted_lines \n] - #append output $part_header \n - } - - set r 0 - set rmax [expr {[llength $cells]-1}] - - - set blims_mid $boxlimits - set blims_top $boxlimits - set blims_bot $boxlimits - set blims_top_headerless $boxlimits_headerless - set blims_only $boxlimits - set blims_only_headerless $boxlimits_headerless - if {!$show_seps_h} { - set blims_mid [struct::set difference $blims_mid $midseps_h] - set blims_top [struct::set difference $blims_top $topseps_h] - set blims_top_headerless [struct::set difference $blims_top_headerless $topseps_h] - } - if {!$show_seps_v} { - set blims_mid [struct::set difference $blims_mid $midseps_v] - set blims_top [struct::set difference $blims_top $topseps_v] - set blims_top_headerless [struct::set difference $blims_top_headerless $topseps_v] - set blims_bot [struct::set difference $blims_bot $botseps_v] - set blims_only [struct::set difference $blims_only $onlyseps_v] - set blims_only_headerless [struct::set difference $blims_only_headerless $onlyseps_v] - } - - set colidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] ;#convert possible end-1,2+2 etc expression to >= 0 integer in dict range - - set opt_col_ansibase [tcl::dict::get $o_columndefs $colidx -ansibase] ;#ordinary merge of codes already done in configure_column - #set colwidth [my column_width $colidx] - - set body_ansibase [tcl::dict::get $o_opts_table -ansibase_body] - #set ansibase [punk::ansi::codetype::sgr_merge_singles [list $body_ansibase $opt_col_ansibase]] ;#allow col to override body - set body_ansiborder [tcl::dict::get $o_opts_table -ansiborder_body] - if {[tcl::dict::get $o_opts_table -frametype] eq "block"} { - #block is the only style where bg colour can fill the frame content area exactly if the L-shaped border elements are styled - #we need to only accept background ansi codes from the columndef ansibase for this - set col_bg [punk::ansi::codetype::sgr_merge_singles [list $opt_col_ansibase] -filter_fg 1] ;#special merge for block borders - don't override fg colours - set border_ansi $body_ansibase$body_ansiborder$col_bg - } else { - set border_ansi $body_ansibase$body_ansiborder - } - - - set r 0 - set ftblock [expr {[tcl::dict::get $o_opts_table -frametype] eq "block"}] - foreach c $cells { - #cells in column - each new c is in a different row - set row_ansibase [tcl::dict::get $o_rowdefs $r -ansibase] - set row_bg "" - if {$row_ansibase ne ""} { - set row_bg [punk::ansi::codetype::sgr_merge_singles [list $row_ansibase] -filter_fg 1] - } - - set ansibase $body_ansibase$opt_col_ansibase - #todo - joinleft,joinright,joindown based on opts in args - set cell_ansibase "" - - set ansiborder_body_col_row $border_ansi$row_bg - set ansiborder_final $ansiborder_body_col_row - #$c will always have ansi resets due to overtype behaviour ? - #todo - review overtype - if {[punk::ansi::ta::detect $c]} { - #use only the last ansi sequence in the cell value - #Filter out foreground and use background for ansiborder override - set parts [punk::ansi::ta::split_codes_single $c] - #we have detected ansi - so there will always be at least 3 parts beginning and ending with pt pt,ansi,pt,ansi...,pt - set codes [list] - foreach {pt cd} $parts { - if {$cd ne ""} { - lappend codes $cd - } - } - #set takebg [lindex $parts end-1] - #set cell_bg [punk::ansi::codetype::sgr_merge_singles [list $takebg] -filter_fg 1] - set cell_bg [punk::ansi::codetype::sgr_merge_singles $codes -filter_fg 1 -filter_reset 1] - #puts --->[ansistring VIEW $codes] - - if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end]]} { - if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end-1]]} { - #special case double reset at end of content - set cell_ansi_tail [punk::ansi::codetype::sgr_merge_singles $codes] ;#no filters - set ansibase "" - set row_ansibase "" - if {$ftblock} { - set ansiborder_final [punk::ansi::codetype::sgr_merge [list $ansiborder_body_col_row] -filter_bg 1] - } - set cell_ansibase $cell_ansi_tail - } else { - #single trailing reset in content - set cell_ansibase "" ;#cell doesn't contribute to frame's ansibase - } - } else { - if {$ftblock} { - #no resets - use cell's bg to extend to the border - only for block frames - set ansiborder_final $ansiborder_body_col_row$cell_bg - } - set cell_ansibase $cell_bg - } - } - - set ansibase_final $ansibase$row_ansibase$cell_ansibase - - if {$r == 0} { - if {$r == $rmax} { - set joins [lremove $joins [lsearch $joins down*]] - set bmap $onlymap - if {$do_show_header} { - set blims $blims_only - } else { - set blims $blims_only_headerless - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts only$opt_posn] ] - } - } else { - set bmap $topmap - if {$do_show_header} { - set blims $blims_top - } else { - set blims $blims_top_headerless - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts top$opt_posn] ] - } - } - set rowframe [textblock::frame -type [tcl::dict::get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c] - set return_bodywidth [textblock::widthtopline $rowframe] ;#frame lines always same width - just look at top line - append part_body $rowframe \n - } else { - if {$r == $rmax} { - set joins [lremove $joins [lsearch $joins down*]] - set bmap $botmap - set blims $blims_bot - if {![tcl::dict::get $o_opts_table -show_edge]} { - set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts bottom$opt_posn] ] - } - } else { - set bmap $midmap - set blims $blims_mid ;#will only be reduced from boxlimits if -show_seps was processed above - if {![tcl::dict::get $o_opts_table -show_edge]} { - set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts middle$opt_posn] ] - } - } - append part_body [textblock::frame -type [tcl::dict::get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c]\n - } - incr r - } - #return empty (zero content height) row if no rows - if {![llength $cells]} { - set joins [lremove $joins [lsearch $joins down*]] - #we need to know the width of the column to setup the empty cell properly - #even if no header displayed - we should take account of any defined column widths - set colwidth [my column_width $index_expression] - - if {$do_show_header} { - set blims $blims_only - } else { - append part_body \n - set blims $blims_only_headerless - } - #note that if show_edge is 0 - then for this empty line - we will not expect to see any bars - #This is because the frame with no data had vertical components made entirely of corner elements - #we could just append a newline when -show_edge is zero, but we want the correct width even when empty - for proper column joins when there are colspanned headers. - # - if {![tcl::dict::get $o_opts_table -show_edge]} { - #set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts only$opt_posn] ] - #append output [textblock::frame -width [expr {$colwidth + 2}] -type [tcl::dict::get $ftypes body] -boxlimits $blims -boxmap $onlymap -joins $joins]\n - append part_body [tcl::string::repeat " " $colwidth] \n - set return_bodywidth $colwidth - } else { - set emptyframe [textblock::frame -width [expr {$colwidth + 2}] -type [tcl::dict::get $ftypes body] -boxlimits $blims -boxmap $onlymap -joins $joins] - append part_body $emptyframe \n - set return_bodywidth [textblock::width $emptyframe] - } - } - #assert bodywidth is integer >=0 whether there are rows or not - - #trim only 1 newline - if {[tcl::string::index $part_body end] eq "\n"} { - set part_body [tcl::string::range $part_body 0 end-1] - } - set return_bodyheight [textblock::height $part_body] - #append output $part_body - - if {$opt_return eq "string"} { - if {$part_header ne ""} { - set output $part_header - if {$part_body ne ""} { - append output \n $part_body - } - } else { - set output $part_body - } - return $output - } else { - return [tcl::dict::create header $part_header body $part_body headerwidth $return_headerwidth headerheight $return_headerheight bodywidth $return_bodywidth bodyheight $return_bodyheight] - } - } - - method get_column_cells_by_index {index_expression} { - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - set range "" - if {[tcl::dict::size $o_columndefs] > 0} { - set range "0..[expr {[tcl::dict::size $o_columndefs] -1}]" - } else { - set range empty - } - 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 ansibase_col [tcl::dict::get $cdef -ansibase] - set textalign [tcl::dict::get $cdef -textalign] - switch -- $textalign { - left {set pad right} - right {set pad left} - default { - set pad "centre" ;#todo? - } - } - - 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] - #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 output [tcl::dict::create] - tcl::dict::set output headers [list] - - set showing_vseps [my Showing_vseps] - for {set hrow 0} {$hrow < $num_header_rows} {incr hrow} { - set hdr [lindex $headerlist $hrow] - set header_maxdataheight [my header_height $hrow] ;#from cached headerstates - set headerrow_colspans [tcl::dict::get $all_colspans $hrow] - 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 -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] - set hval_lines [split $hdr \n] - set hval_lines [concat $hval_lines $hcell_lines] - set hval_lines [lrange $hval_lines 0 $header_maxdataheight-1] ;#vertical align top - set hval_block [::join $hval_lines \n] - set hcell [textblock::pad $hval_block -width $this_hdrwidth -padchar " " -within_ansi 1 -which $pad] - tcl::dict::lappend output headers $hcell - } - - - #set colwidth [my column_width $cidx] - #set cell_line_blank [tcl::string::repeat " " $colwidth] - set datawidth [my column_datawidth $cidx -headers 0 -footers 0 -data 1 -cached 1] - set cell_line_blank [tcl::string::repeat " " $datawidth] - - - - set items [tcl::dict::get $o_columndata $cidx] - #puts "---> columndata $o_columndata" - - #set opt_row_ansibase [tcl::dict::get $o_rowdefs $r -ansibase] - #set cell_ansibase $ansibase_body$ansibase_col$opt_row_ansibase - - tcl::dict::set output cells [list];#ensure we return something for cells key if no items in list - set r 0 - foreach cval $items { - #todo move to row_height method ? - set maxdataheight [tcl::dict::get $o_rowstates $r -maxheight] - set rowdefminh [tcl::dict::get $o_rowdefs $r -minheight] - set rowdefmaxh [tcl::dict::get $o_rowdefs $r -maxheight] - if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} { - #an exact height is defined for the row - set rowh $rowdefminh - } else { - if {$rowdefminh eq ""} { - if {$rowdefmaxh eq ""} { - #both defs empty - set rowh $maxdataheight - } else { - set rowh [expr {min(1,$rowdefmaxh,$maxdataheight)}] - } - } else { - if {$rowdefmaxh eq ""} { - set rowh [expr {max($rowdefminh,$maxdataheight)}] - } else { - if {$maxdataheight < $rowdefminh} { - set rowh $rowdefminh - } else { - set rowh [expr {max($rowdefminh,$maxdataheight)}] - } - } - } - } - - set cell_lines [lrepeat $rowh $cell_line_blank] - #set cell_blank [join $cell_lines \n] - - - set cval_lines [split $cval \n] - set cval_lines [concat $cval_lines $cell_lines] - set cval_lines [lrange $cval_lines 0 $rowh-1] - set cval_block [::join $cval_lines \n] - - - set cell [textblock::pad $cval_block -width $datawidth -padchar " " -within_ansi 1 -which $pad] - #set cell [textblock::pad $cval_block -width $colwidth -padchar " " -within_ansi 0 -which left] - tcl::dict::lappend output cells $cell - - incr r - } - return $output - } - method get_column_values_by_index {index_expression} { - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - return - } - return [tcl::dict::get $o_columndata $cidx] - } - method debug {args} { - #nice to lay this out with tables - but this is the one function where we really should provide the ability to avoid tables in case things get really broken (e.g major refactor) - set defaults [tcl::dict::create\ - -usetables 1\ - ] - foreach {k v} $args { - switch -- $k { - -usetables {} - default { - error "table debug unrecognised option '$k'. Known options: [tcl::dict::keys $defaults]" - } - } - } - set opts [tcl::dict::merge $defaults $args] - set opt_usetables [tcl::dict::get $opts -usetables] - - puts stdout "rowdefs: $o_rowdefs" - puts stdout "rowstates: $o_rowstates" - #puts stdout "columndefs: $o_columndefs" - puts stdout "columndefs:" - if {!$opt_usetables} { - tcl::dict::for {k v} $o_columndefs { - puts " $k $v" - } - } else { - set t [textblock::class::table new] - $t add_column -headers "Col" - tcl::dict::for {col coldef} $o_columndefs { - foreach property [tcl::dict::keys $coldef] { - if {$property eq "-ansireset"} { - continue - } - $t add_column -headers $property - } - break - } - - #build our inner tables first so we can sync widths - set col_header_tables [tcl::dict::create] - set max_widths [tcl::dict::create 0 0 1 0 2 0 3 0] ;#max inner table column widths - tcl::dict::for {col coldef} $o_columndefs { - set row [list $col] - set colheaders [tcl::dict::get $coldef -headers] - #inner table probably overkill here ..but just as easy - set htable [textblock::class::table new] - $htable configure -show_header 1 -show_edge 0 -show_hseps 0 - $htable add_column -headers row - $htable add_column -headers text - $htable add_column -headers WxH - $htable add_column -headers span - set hnum 0 - set spans [tcl::dict::get $o_columndefs $col -header_colspans] - foreach h $colheaders s $spans { - lassign [textblock::size $h] _w width _h height - $htable add_row [list "$hnum " $h "${width}x${height}" $s] - incr hnum - } - $htable configure_column 0 -ansibase [a+ web-dimgray] - tcl::dict::set col_header_tables $col $htable - set colwidths [$htable column_widths] - set icol 0 - foreach w $colwidths { - if {$w > [tcl::dict::get $max_widths $icol]} { - tcl::dict::set max_widths $icol $w - } - incr icol - } - } - - #safe jumptable test - #dict for {col coldef} $o_columndefs {} - tcl::dict::for {col coldef} $o_columndefs { - set row [list $col] - #safe jumptable test - #dict for {property val} $coldef {} - tcl::dict::for {property val} $coldef { - switch -- $property { - -ansireset {continue} - -headers { - set htable [tcl::dict::get $col_header_tables $col] - tcl::dict::for {innercol maxw} $max_widths { - $htable configure_column $innercol -minwidth $maxw -blockalign left - } - lappend row [$htable print] - $htable destroy - } - default { - lappend row $val - } - } - } - $t add_row $row - } - - - - - $t configure -show_header 1 - puts stdout [$t print] - $t destroy - } - puts stdout "columnstates: $o_columnstates" - puts stdout "headerstates: $o_headerstates" - tcl::dict::for {k coldef} $o_columndefs { - if {[tcl::dict::exists $o_columndata $k]} { - set headerlist [tcl::dict::get $coldef -headers] - set coldata [tcl::dict::get $o_columndata $k] - set colinfo "rowcount: [llength $coldata]" - set allfields [concat $headerlist $coldata] - if {[llength $allfields]} { - set widest [tcl::mathfunc::max {*}[lmap v $allfields {textblock::width $v}]] - } else { - set widest 0 - } - append colinfo " widest of headers and data: $widest" - } else { - set colinfo "WARNING - no columndata record for column key '$k'" - } - puts stdout "column $k columndata info: $colinfo" - } - set result "" - set cols [list] - set max [expr {[tcl::dict::size $o_columndefs]-1}] - foreach c [tcl::dict::keys $o_columndefs] { - if {$c == 0} { - lappend cols [my get_column_by_index $c -position left] " " - } elseif {$c == $max} { - lappend cols [my get_column_by_index $c -position right] - } else { - lappend cols [my get_column_by_index $c -position inner] " " - } - } - append result [textblock::join -- {*}$cols] - return $result - } - #column width including headers - but without colspan consideration - method column_width_configured {index_expression} { - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - return - } - #assert cidx is now >=0 integer within the range of defined columns - set cdef [tcl::dict::get $o_columndefs $cidx] - set defminw [tcl::dict::get $cdef -minwidth] - set defmaxw [tcl::dict::get $cdef -maxwidth] - if {"$defminw$defmaxw" ne "" && $defminw eq $defmaxw} { - #an exact width is defined for the column - no need to look at data width - set colwidth $defminw - } else { - #set widest [my column_datawidth $cidx -headers 1 -data 1 -footers 1] - set hwidest [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] - #set hwidest [my column_datawidth $cidx -headers 1 -colspan 1 -data 0 -footers 1] - #set hwidest_singlespan ?? - set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] - set widest [expr {max($hwidest,$bwidest)}] - #todo - predetermine if any items in column contain newlines and are truncated vertically due to o_rowdefs configuration. - #if so - a truncated line shouldn't be included in our width calculation - if {$defminw eq ""} { - if {$defmaxw eq ""} { - set colwidth $widest - } else { - set colwidth [expr {min($defmaxw,$widest)}] - } - } else { - if {$defmaxw eq ""} { - set colwidth [expr {max($defminw,$widest)}] - } else { - if {$widest < $defminw} { - set colwidth $defminw - } else { - if {$widest > $defmaxw} { - set colwidth $defmaxw - } else { - set colwidth [expr {max($defminw,$widest)}] - } - } - } - } - } - return $colwidth - } - - method column_width {index_expression} { - if {[llength $o_calculated_column_widths] != [tcl::dict::size $o_columndefs]} { - my calculate_column_widths -algorithm $o_column_width_algorithm - } - return [lindex $o_calculated_column_widths $index_expression] - } - method column_widths {} { - if {[llength $o_calculated_column_widths] != [tcl::dict::size $o_columndefs]} { - my calculate_column_widths -algorithm $o_column_width_algorithm - } - return $o_calculated_column_widths - } - - #width of a table includes borders and seps - #whereas width of a column refers to the borderless width (inner width) - method width {} { - #calculate width based on assumption frame verticals are 1-wide - review - what about custom unicode double-wide frame? - set colwidths [my column_widths] - set contentwidth [tcl::mathop::+ {*}$colwidths] - set twidth $contentwidth - if {[my Showing_vseps]} { - incr twidth [llength $colwidths] - incr twidth -1 - } - if {[tcl::dict::get $o_opts_table -show_edge]} { - incr twidth 2 - } - return $twidth - } - - #column *body* content width - method basic_column_width {index_expression} { - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - return - } - #puts "===column_width $index_expression" - #assert cidx is now >=0 integer within the range of defined columns - set cdef [tcl::dict::get $o_columndefs $cidx] - set defminw [tcl::dict::get $cdef -minwidth] - set defmaxw [tcl::dict::get $cdef -maxwidth] - if {"$defminw$defmaxw" ne "" && $defminw eq $defmaxw} { - #an exact width is defined for the column - no need to look at data width - #review - this can result in truncation of spanning headers - even though there is enough width in the span-cell to place the full header - set colwidth $defminw - } else { - #set widest [my column_datawidth $cidx -headers 0 -data 1 -footers 0] - set widest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] - #todo - predetermine if any items in column contain newlines and are truncated vertically due to o_rowdefs configuration. - #if so - a truncated line shouldn't be included in our width calculation - if {$defminw eq ""} { - if {$defmaxw eq ""} { - set colwidth $widest - } else { - set colwidth [expr {min($defmaxw,$widest)}] - } - } else { - if {$defmaxw eq ""} { - set colwidth [expr {max($defminw,$widest)}] - } else { - if {$widest < $defminw} { - set colwidth $defminw - } else { - if {$widest > $defmaxw} { - set colwidth $defmaxw - } else { - set colwidth [expr {max($defminw,$widest)}] - } - } - } - } - } - set configured_widths [list] - foreach c [tcl::dict::keys $o_columndefs] { - lappend configured_widths [my column_width_configured $c] - } - set header_colspans [my header_colspans] - set width_max $colwidth - set test_width $colwidth - set showing_vseps [my Showing_vseps] - set thiscol_widest_header [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] - tcl::dict::for {h colspans} $header_colspans { - set spanc [lindex $colspans $cidx] - #set headers [tcl::dict::get $cdef -headers] - #set thiscol_widest_header 0 - #if {[llength $headers] > 0} { - # set thiscol_widest_header [tcl::mathfunc::max {*}[lmap v $headers {textblock::width $v}]] - #} - if {$spanc eq "1"} { - if {$thiscol_widest_header > $colwidth} { - set test_width [expr {max($thiscol_widest_header,$colwidth)}] - if {$defmaxw ne ""} { - set test_width [expr {min($colwidth,$defmaxw)}] - } - } - set width_max [expr {max($test_width,$width_max)}] - continue - } - 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] - while {$spanlength eq "0" && $cnext < [llength $colspans]} { - lappend spanned $cnext - incr cnext - set spanlength [lindex $colspans $cnext] - } - set others_width 0 - foreach col $spanned { - incr others_width [lindex $configured_widths $col] - if {$showing_vseps} { - incr others_width 1 - } - } - set total_spanned_width [expr {$width_max + $others_width}] - if {$thiscol_widest_header > $total_spanned_width} { - #this just allocates the extra space in the current column - which is not great. - #A proper algorithm for distributing width created by headers to all the spanned columns is needed. - #This is a tricky problem with multiple header lines and arbitrary spans. - #The calculation should probably be done on the table as a whole first and this function should just look up that result. - #Trying to calculate on a specific column only is unlikely to be easy or efficient. - set needed [expr {$thiscol_widest_header - $total_spanned_width}] - #puts "-->>col $cidx needed ($thiscol_widest_header - $total_spanned_width): $needed (spanned $spanned)" - if {$defmaxw ne ""} { - set test_width [expr {min($colwidth+$needed,$defmaxw)}] - } else { - set test_width [expr {$colwidth + $needed}] - } - } - } - set width_max [expr {max($test_width,$width_max)}] - } - - #alternative to all the above shennanigans.. let the body cell data determine the size and just wrap the headers - #could also split the needed width amongst the spanned columns? configurable for whether cells expand? - set expand_first_column 1 - if {$expand_first_column} { - set colwidth $width_max - } - - #puts "---column_width $cidx = $colwidth" - return $colwidth - } - method Showing_vseps {} { - #review - show_seps and override mechanism for show_vseps show_hseps - document. - set seps [tcl::dict::get $o_opts_table -show_seps] - set vseps [tcl::dict::get $o_opts_table -show_vseps] - if {$seps eq ""} { - if {$vseps eq "" || $vseps} { - return true - } - } elseif {$seps} { - if {$vseps eq "" || $vseps} { - return true - } - } else { - if {$vseps ne "" && $vseps} { - return true - } - } - return false - } - - method column_datawidth {index_expression args} { - set opts [tcl::dict::create\ - -headers 0\ - -footers 0\ - -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 { - -headers - -footers - -colspan - -data - -cached { - tcl::dict::set opts $k $v - } - default { - error "column_datawidth unrecognised flag '$k'. Known flags: [tcl::dict::keys $opts]" - } - } - } - 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] - if {$cidx eq ""} { - return - } - - if {[tcl::dict::get $opts -cached]} { - set hwidest 0 - set bwidest 0 - set fwidest 0 - if {[tcl::dict::get $opts -headers]} { - 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_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]} { - set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] - } - if {[tcl::dict::get $opts -footers]} { - #TODO! - #set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthfooterseen] - } - return [expr {max($hwidest,$bwidest,$fwidest)}] - } - - #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]} { - 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]} { - lappend values {*}[tcl::dict::get $o_columndata $cidx] - } - } - if {[tcl::dict::get $opts -footers]} { - lappend values {*}[tcl::dict::get $o_columndefs $cidx -footers] - } - if {[llength $values]} { - set valwidest [tcl::mathfunc::max {*}[lmap v $values {textblock::width $v}]] - set widest [expr {max($valwidest,$hwidest)}] - } else { - set widest $hwidest - } - return $widest - } - #print1 uses basic column joining - useful for testing/debug especially with colspans - method print1 {args} { - if {![llength $args]} { - set cols [tcl::dict::keys $o_columndata] - } else { - set cols [list] - foreach colspec $args { - set allcols [tcl::dict::keys $o_columndata] - if {[tcl::string::first .. $colspec] >=0} { - set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] - if {[llength $parts] != 3} { - error "[namespace::current]::table error invalid print specification '$colspec'" - } - lassign $parts from _dd to - if {$from eq ""} {set from 0 } - if {$to eq ""} {set to end} - - set indices [lrange $allcols $from $to] - lappend cols {*}$indices - } else { - set c [lindex $allcols $colspec] - if {$c ne ""} { - lappend cols $c - } - } - } - } - set blocks [list] - set colposn 0 - set numposns [llength $cols] - foreach c $cols { - set flags [list] - if {$colposn == 0 && $colposn == $numposns-1} { - set flags [list -position solo] - } elseif {$colposn == 0} { - set flags [list -position left] - } elseif {$colposn == $numposns-1} { - set flags [list -position right] - } else { - set flags [list -position inner] - } - lappend blocks [my get_column_by_index $c {*}$flags] - incr colposn - } - if {[llength $blocks]} { - return [textblock::join -- {*}$blocks] - } else { - return "No columns matched" - } - } - method columncalc_spans {allocmethod} { - set colwidths [tcl::dict::create] ;# to use tcl::dict::incr - set colspace_added [tcl::dict::create] - - set ordered_spans [tcl::dict::create] - tcl::dict::for {col spandata} [my spangroups] { - set dwidth [my column_datawidth $col -data 1 -headers 0 -footers 0 -cached 1] - set minwidth [tcl::dict::get $o_columndefs $col -minwidth] - set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth] - if {$minwidth ne ""} { - if {$dwidth < $minwidth} { - set dwidth $minwidth - } - } - if {$maxwidth ne ""} { - if {$dwidth > $maxwidth} { - set dwidth $maxwidth - } - } - tcl::dict::set colwidths $col $dwidth ;#spangroups is ordered by column - so colwidths dict will be correctly ordered - tcl::dict::set colspace_added $col 0 - - set spanlengths [tcl::dict::get $spandata spanlengths] - foreach slen $spanlengths { - set spans [tcl::dict::get $spandata spangroups $slen] - set spans [lsort -index 7 -integer $spans] - foreach s $spans { - set hwidth [tcl::dict::get $s headerwidth] - set hrow [tcl::dict::get $s hrow] - set scol [tcl::dict::get $s startcol] - tcl::dict::set ordered_spans $scol,$hrow membercols $col $dwidth - tcl::dict::set ordered_spans $scol,$hrow headerwidth $hwidth - } - } - } - - #safe jumptable test - #dict for {spanid spandata} $ordered_spans {} - tcl::dict::for {spanid spandata} $ordered_spans { - lassign [split $spanid ,] startcol hrow - set memcols [tcl::dict::get $spandata membercols] ;#dict with col and initial width - we ignore initial width, it's there in case we want to allocate space based on initial data width ratios - set colids [tcl::dict::keys $memcols] - set hwidth [tcl::dict::get $spandata headerwidth] - set num_cols_spanned [tcl::dict::size $memcols] - if {$num_cols_spanned == 1} { - set col [lindex $memcols 0] - set space_to_alloc [expr {$hwidth - [tcl::dict::get $colwidths $col]}] - if {$space_to_alloc > 0} { - set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth] - if {$maxwidth ne ""} { - if {$maxwidth > [tcl::dict::get $colwidths $col]} { - set can_alloc [expr {$maxwidth - [tcl::dict::get $colwidths $col]}] - } else { - set can_alloc 0 - } - set will_alloc [expr {min($space_to_alloc,$can_alloc)}] - } else { - set will_alloc $space_to_alloc - } - if {$will_alloc} { - #tcl::dict::set colwidths $col $hwidth - tcl::dict::incr colwidths $col $will_alloc - tcl::dict::set colspace_added $col $will_alloc - } - #log! - #if {$will_alloc < $space_to_alloc} { - # #todo - debug only - # puts stderr "max width $maxwidth hit for col $col - cannot allocate extra [expr {$space_to_alloc - $will_alloc}]" - #} - } - } elseif {$num_cols_spanned > 1} { - set spannedwidth 0 - foreach col $colids { - incr spannedwidth [tcl::dict::get $colwidths $col] - } - set space_to_alloc [expr {$hwidth - $spannedwidth}] - if {[my Showing_vseps]} { - set sepcount [expr {$num_cols_spanned -1}] - incr space_to_alloc -$sepcount - } - #review - we want to reduce overallocation to earlier or later columns - hence the use of colspace_added - switch -- $allocmethod { - least { - #add to least-expanded each time - #safer than method 1 - pretty balanced - if {$space_to_alloc > 0} { - for {set i 0} {$i < $space_to_alloc} {incr i} { - set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] - set ordered_all_colids [tcl::dict::keys $ordered_colspace_added] - foreach testcolid $ordered_all_colids { - if {$testcolid in $colids} { - #assert - we will always find a match - set colid $testcolid - break - } - } - tcl::dict::incr colwidths $colid - tcl::dict::incr colspace_added $colid - } - } - } - least_unmaxed { - #TODO - fix header truncation/overflow issues when they are restricted by column maxwidth - #(we should be able to collapse column width to zero and have header colspans gracefully respond) - #add to least-expanded each time - #safer than method 1 - pretty balanced - if {$space_to_alloc > 0} { - for {set i 0} {$i < $space_to_alloc} {incr i} { - set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] - set ordered_all_colids [tcl::dict::keys $ordered_colspace_added] - set colid "" - foreach testcolid $ordered_all_colids { - set maxwidth [tcl::dict::get $o_columndefs $testcolid -maxwidth] - set can_alloc [expr {$maxwidth eq "" || $maxwidth > [tcl::dict::get $colwidths $testcolid]}] - if {$testcolid in $colids} { - if {$can_alloc} { - set colid $testcolid - break - } else { - #remove from future consideration in for loop - #log! - #puts stderr "max width $maxwidth hit for col $testcolid" - tcl::dict::unset colspace_added $testcolid - } - } - } - if {$colid ne ""} { - tcl::dict::incr colwidths $colid - tcl::dict::incr colspace_added $colid - } - } - } - } - all { - #adds space to all columns - not just those spanned - risk of underallocating and truncating some headers! - #probably not a good idea for tables with complex headers and spans - while {$space_to_alloc > 0} { - set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] - set ordered_colids [tcl::dict::keys $ordered_colspace_added] - - foreach col $ordered_colids { - tcl::dict::incr colwidths $col - tcl::dict::incr colspace_added $col - incr space_to_alloc -1 - if {$space_to_alloc == 0} { - break - } - } - } - - } - } - } - } - - set column_widths [tcl::dict::values $colwidths] - #todo - -maxwidth etc - set table_minwidth [tcl::dict::get $o_opts_table -minwidth] ;#min width including frame elements - if {[tcl::string::is integer -strict $table_minwidth]} { - set contentwidth [tcl::mathop::+ {*}$column_widths] - set twidth $contentwidth - if {[my Showing_vseps]} { - incr twidth [llength $column_widths] - incr twidth -1 - } - if {[tcl::dict::get $o_opts_table -show_edge]} { - incr twidth 2 - } - # - set shortfall [expr {$table_minwidth - $twidth}] - if {$shortfall > 0} { - set space_to_alloc $shortfall - while {$space_to_alloc > 0} { - set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] - set ordered_colids [tcl::dict::keys $ordered_colspace_added] - - foreach col $ordered_colids { - tcl::dict::incr colwidths $col - tcl::dict::incr colspace_added $col - incr space_to_alloc -1 - if {$space_to_alloc == 0} { - break - } - } - } - set column_widths [tcl::dict::values $colwidths] - } - - } - - return [list ordered_spans $ordered_spans colwidths $column_widths adjustments $colspace_added] - } - - #spangroups keyed by column - method spangroups {} { - set column_count [tcl::dict::size $o_columndefs] - set spangroups [tcl::dict::create] - set headerwidths [tcl::dict::create] ;#key on col,hrow - foreach c [tcl::dict::keys $o_columndefs] { - tcl::dict::set spangroups $c [list spanlengths {}] - set spanlist [my column_get_spaninfo $c] - set index_spanlen_val 5 - set spanlist [lsort -index $index_spanlen_val -integer $spanlist] - set ungrouped $spanlist - - while {[llength $ungrouped]} { - set spanlen [lindex $ungrouped 0 $index_spanlen_val] - set spangroup_posns [lsearch -all -index $index_spanlen_val $ungrouped $spanlen] - set sgroup [list] - foreach p $spangroup_posns { - set spaninfo [lindex $ungrouped $p] - set hcol [tcl::dict::get $spaninfo startcol] - set hrow [tcl::dict::get $spaninfo hrow] - set header [lindex [tcl::dict::get $o_columndefs $hcol -headers] $hrow] - if {[tcl::dict::exists $headerwidths $hcol,$hrow]} { - set hwidth [tcl::dict::get $headerwidths $hcol,$hrow] - } else { - set hwidth [textblock::width $header] - tcl::dict::set headerwidths $hcol,$hrow $hwidth - } - lappend spaninfo headerwidth $hwidth - lappend sgroup $spaninfo - } - set spanlengths [tcl::dict::get $spangroups $c spanlengths] - lappend spanlengths $spanlen - tcl::dict::set spangroups $c spanlengths $spanlengths - tcl::dict::set spangroups $c spangroups $spanlen $sgroup - set ungrouped [lremove $ungrouped {*}$spangroup_posns] - } - } - return $spangroups - } - method column_get_own_spans {cidx} { - set colspans_for_column [tcl::dict::get $o_columndefs $cidx -header_colspans] - } - method column_get_spaninfo {cidx} { - set spans_by_header [my header_colspans] - set colspans_for_column [tcl::dict::get $o_columndefs $cidx -header_colspans] - set spaninfo [list] - set numcols [tcl::dict::size $o_columndefs] - #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 "any" || $thiscol_spanval > 0} { - set spanstartcol $cidx ;#own column - 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 any or a non-zero value - for {set i $cidx} {$i > -1} {incr i -1} { - set s [lindex $rawspans $i] - if {$s eq "any" || $s > 0} { - set spanstartcol $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 - } - break - } - } - } - #assert - we should always find 1 answer for each header row - lappend spaninfo [list hrow $hrow startcol $spanstartcol spanlen $spanlen] - } - return $spaninfo - } - method calculate_column_widths {args} { - set column_count [tcl::dict::size $o_columndefs] - - set opts [tcl::dict::create\ - -algorithm $o_column_width_algorithm\ - ] - foreach {k v} $args { - switch -- $k { - -algorithm { - tcl::dict::set opts $k $v - } - default { - error "Unknown option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - set opt_algorithm [tcl::dict::get $opts -algorithm] - #puts stderr "--- recalculating column widths -algorithm $opt_algorithm" - set known_algorithms [list basic simplistic span span2] - switch -- $opt_algorithm { - basic { - #basic column by column - This allocates extra space to first span/column as they're encountered. - #This can leave the table quite unbalanced with regards to whitespace and the table is also not as compact as it could be especially with regards to header colspans - #The header values can extend over some of the spanned columns - but not optimally so. - set o_calculated_column_widths [list] - for {set c 0} {$c < $column_count} {incr c} { - lappend o_calculated_column_widths [my basic_column_width $c] - } - } - simplistic { - #just uses the widest column data or header element. - #this is even less compact than basic and doesn't allow header colspan values to extend beyond their first spanned column - #This is a conservative option potentially useful in testing/debugging. - set o_calculated_column_widths [list] - for {set c 0} {$c < $column_count} {incr c} { - lappend o_calculated_column_widths [my column_width_configured $c] - } - } - span { - #widest of smallest spans first method - #set calcresult [my columncalc_spans least] - set calcresult [my columncalc_spans least_unmaxed] - set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] - } - span2 { - #allocates more evenly - but truncates headers sometimes - set calcresult [my columncalc_spans all] - set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] - } - default { - error "calculate_column_widths unknown algorithm $opt_algorithm. Known algorithms: $known_algorithms" - } - } - #remember the last algorithm used - set o_column_width_algorithm $opt_algorithm - return $o_calculated_column_widths - } - method print2 {args} { - variable full_column_cache - set full_column_cache [tcl::dict::create] - - if {![llength $args]} { - set cols [tcl::dict::keys $o_columndata] - } else { - set cols [list] - foreach colspec $args { - set allcols [tcl::dict::keys $o_columndata] - if {[tcl::string::first .. $colspec] >=0} { - set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] - if {[llength $parts] != 3} { - error "[namespace::current]::table error invalid print specification '$colspec'" - } - lassign $parts from _dd to - if {$from eq ""} {set from 0} - if {$to eq ""} {set to end} - - set indices [lrange $allcols $from $to] - lappend cols {*}$indices - } else { - set c [lindex $allcols $colspec] - if {$c ne ""} { - lappend cols $c - } - } - } - } - set blocks [list] - set colposn 0 - set numposns [llength $cols] - set padwidth 0 - set table "" - foreach c $cols { - set flags [list] - if {$colposn == 0 && $colposn == $numposns-1} { - set flags [list -position solo] - } elseif {$colposn == 0} { - set flags [list -position left] - } elseif {$colposn == $numposns-1} { - set flags [list -position right] - } else { - set flags [list -position inner] - } - #lappend blocks [my get_column_by_index $c {*}$flags] - #todo - only check and store in cache if table has header or footer colspans > 1 - if {[tcl::dict::exists $full_column_cache $c]} { - #puts "!!print used full_column_cache for $c" - set columninfo [tcl::dict::get $full_column_cache $c] - } else { - set columninfo [my get_column_by_index $c -return dict {*}$flags] - tcl::dict::set full_column_cache $c $columninfo - } - set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] - set bodywidth [tcl::dict::get $columninfo bodywidth] - - if {$table eq ""} { - set table $nextcol - set height [textblock::height $table] ;#only need to get height once at start - } else { - set nextcol [textblock::join -- [textblock::block $padwidth $height $TSUB] $nextcol] - set table [overtype::renderspace -expand_right 1 -transparent $TSUB $table[unset table] $nextcol] - #JMN - - #set nextcol [textblock::join -- [textblock::block $padwidth $height "\uFFFF"] $nextcol] - #set table [overtype::renderspace -expand_right 1 -transparent \uFFFF $table $nextcol] - } - incr padwidth $bodywidth - incr colposn - } - - if {[llength $cols]} { - #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? - set titlepad [tcl::string::repeat $TSUB $offset] - if {[tcl::dict::get $o_opts_table -title] ne ""} { - set titlealign [tcl::dict::get $o_opts_table -titlealign] - switch -- $titlealign { - left { - set tstring $titlepad[tcl::dict::get $o_opts_table -title] - } - right { - set tstring [tcl::dict::get $o_opts_table -title]$titlepad - } - default { - set tstring [tcl::dict::get $o_opts_table -title] - } - } - set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] - switch -- $opt_titletransparent { - 0 { - set mapchar "" - } - 1 { - set mapchar " " - } - default { - #won't work if not a single char - review - check also frame behaviour - set mapchar $opt_titletransparent - } - } - if {$mapchar ne ""} { - set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] - } - set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] - } - } - return $table - } else { - return "No columns matched" - } - } - - # using -startcolumn to do slightly less work - method print3 {args} { - if {![llength $args]} { - set cols [tcl::dict::keys $o_columndata] - } else { - set cols [list] - foreach colspec $args { - set allcols [tcl::dict::keys $o_columndata] - if {[tcl::string::first .. $colspec] >=0} { - set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] - if {[llength $parts] != 3} { - error "[namespace::current]::table error invalid print specification '$colspec'" - } - lassign $parts from _dd to - if {$from eq ""} {set from 0} - if {$to eq ""} {set to end} - - set indices [lrange $allcols $from $to] - lappend cols {*}$indices - } else { - set c [lindex $allcols $colspec] - if {$c ne ""} { - lappend cols $c - } - } - } - } - set blocks [list] - set numposns [llength $cols] - set colposn 0 - set padwidth 0 - set table "" - foreach c $cols { - set flags [list] - if {$colposn == 0 && $colposn == $numposns-1} { - set flags [list -position solo] - } elseif {$colposn == 0} { - set flags [list -position left] - } elseif {$colposn == $numposns-1} { - set flags [list -position right] - } else { - set flags [list -position inner] - } - set columninfo [my get_column_by_index $c -return dict {*}$flags] - set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] - set bodywidth [tcl::dict::get $columninfo bodywidth] - - if {$table eq ""} { - set table $nextcol - set height [textblock::height $table] ;#only need to get height once at start - } else { - set table [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $table $nextcol] - } - incr padwidth $bodywidth - incr colposn - } - - if {[llength $cols]} { - #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? - set titlepad [tcl::string::repeat $TSUB $offset] - if {[tcl::dict::get $o_opts_table -title] ne ""} { - set titlealign [tcl::dict::get $o_opts_table -titlealign] - switch -- $titlealign { - left { - set tstring $titlepad[tcl::dict::get $o_opts_table -title] - } - right { - set tstring [tcl::dict::get $o_opts_table -title]$titlepad - } - default { - set tstring [tcl::dict::get $o_opts_table -title] - } - } - set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] - switch -- $opt_titletransparent { - 0 { - set mapchar "" - } - 1 { - set mapchar " " - } - default { - #won't work if not a single char - review - check also frame behaviour - set mapchar $opt_titletransparent - } - } - if {$mapchar ne ""} { - set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] - } - set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] - } - } - return $table - } else { - return "No columns matched" - } - } - - #print headers and body using different join mechanisms - # using -startcolumn to do slightly less work - method print {args} { - if {![llength $args]} { - set cols [tcl::dict::keys $o_columndata] - } else { - set cols [list] - foreach colspec $args { - set allcols [tcl::dict::keys $o_columndata] - if {[tcl::string::first .. $colspec] >=0} { - set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] - if {[llength $parts] != 3} { - error "[namespace::current]::table error invalid print specification '$colspec'" - } - lassign $parts from _dd to - if {$from eq ""} {set from 0} - if {$to eq ""} {set to end} - - set indices [lrange $allcols $from $to] - lappend cols {*}$indices - } else { - set c [lindex $allcols $colspec] - if {$c ne ""} { - lappend cols $c - } - } - } - } - set numposns [llength $cols] - set colposn 0 - set padwidth 0 - set header_build "" - set body_blocks [list] - set headerheight 0 - foreach c $cols { - set flags [list] - if {$colposn == 0 && $colposn == $numposns-1} { - set flags [list -position solo] - } elseif {$colposn == 0} { - set flags [list -position left] - } elseif {$colposn == $numposns-1} { - set flags [list -position right] - } else { - set flags [list -position inner] - } - set columninfo [my get_column_by_index $c -return dict {*}$flags] - #set nextcol [tcl::dict::get $columninfo column] - set bodywidth [tcl::dict::get $columninfo bodywidth] - set headerheight [tcl::dict::get $columninfo headerheight] - #set nextcol_lines [split $nextcol \n] - #set nextcol_header [join [lrange $nextcol_lines 0 $headerheight-1] \n] - #set nextcol_body [join [lrange $nextcol_lines $headerheight end] \n] - set nextcol_header [tcl::dict::get $columninfo header] - set nextcol_body [tcl::dict::get $columninfo body] - - if {$header_build eq "" && ![llength $body_blocks]} { - set header_build $nextcol_header - lappend body_blocks $nextcol_body - } else { - if {$headerheight > 0} { - set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -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] - } - incr padwidth $bodywidth - incr colposn - } - if {![llength $body_blocks]} { - set body_build "" - } else { - #body blocks should not be ragged - so can use join_basic - set body_build [textblock::join_basic -- {*}$body_blocks] - } - if {$headerheight > 0} { - set table [tcl::string::cat $header_build \n $body_build] - } else { - set table $body_build - } - - if {[llength $cols]} { - if {[tcl::dict::get $o_opts_table -show_edge]} { - #title is considered part of the edge ? - set offset 1 ;#make configurable? - set titlepad [tcl::string::repeat $TSUB $offset] - if {[tcl::dict::get $o_opts_table -title] ne ""} { - set titlealign [tcl::dict::get $o_opts_table -titlealign] - switch -- $titlealign { - left { - set tstring $titlepad[tcl::dict::get $o_opts_table -title] - } - right { - set tstring [tcl::dict::get $o_opts_table -title]$titlepad - } - default { - set tstring [tcl::dict::get $o_opts_table -title] - } - } - set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] - switch -- $opt_titletransparent { - 0 { - set mapchar "" - } - 1 { - set mapchar " " - } - default { - #won't work if not a single char - review - check also frame behaviour - set mapchar $opt_titletransparent - } - } - if {$mapchar ne ""} { - set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] - } - set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] - } - } - return $table - } else { - return "No columns matched" - } - } - method print_bodymatrix {} { - set m [my as_matrix] - $m format 2string - } - - #*** !doctools - #[list_end] - }] - #*** !doctools - # [list_end] [comment {- end enumeration provider_classes }] - #[list_end] [comment {- end itemized list textblock::class groupings -}] - } - } -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# -#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::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 *} - tcl::namespace::import ::term::ansi::code::macros::cd::* - tcl::namespace::eval ::term::ansi::code::macros::cd {tcl::namespace::export -clear} - } - 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 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 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} - $t configure_column 3 -header_colspans {1 0 2 0 0} - $t configure -show_header 1 -ansiborder_header [a+ cyan] - return $t - } - proc spantest3 {} { - 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 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} - $t configure_column 2 -header_colspans {0 0 0 0 1 2} - $t configure_column 4 -headers {"4" "444" "" "" "" "44"} - $t configure -show_header 1 -ansiborder_header [a+ cyan] - return $t - } - - - - proc periodic {args} { - #For an impressive interactive terminal app (javascript) - # see: https://github.com/spirometaxas/periodic-table-cli - set opts [dict get [punk::args::get_dict { - *proc -name textblock::periodic -help "A rudimentary periodic table - This is primarily a test of textblock::class::table" - - -return -default table\ - -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 - -forcecolour -default 0 -type boolean -help "If punk::colour is off - this enables the produced table to still be ansi coloured" - *values -min 0 -max 0 - } $args] opts] - - set opt_return [tcl::dict::get $opts -return] - if {[tcl::dict::get $opts -forcecolour]} { - set fc forcecolour - } else { - set fc "" - } - - #examples ptable.com - set elements [list\ - 1 H "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" He\ - 2 Li Be "" "" "" "" "" "" "" "" "" "" B C N O F Ne\ - 3 Na Mg "" "" "" "" "" "" "" "" "" "" Al Si P S Cl Ar\ - 4 K Ca Sc Ti V Cr Mn Fe Co Ni Cu Zn Ga Ge As Se Br Kr\ - 5 Rb Sr Y Zr Nb Mo Tc Ru Rh Pd Ag Cd In Sn Sb Te I Xe\ - 6 Cs Ba "" Hf Ta W Re Os Ir Pt Au Hg Tl Pb Bi Po At Rn\ - 7 Fr Ra "" Rf Db Sg Bh Hs Mt Ds Rg Cn Nh Fl Mc Lv Ts Og\ - " " " " " " " " " " " " " " " " " " " " " " " " "" "" "" "" "" "" ""\ - "" "" "" 6 La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu\ - "" "" "" 7 Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr\ - ] - - set type_colours [list] - - set ecat [tcl::dict::create] - - set cat_alkaline_earth [list Be Mg Ca Sr Ba Ra] - set ansi [a+ {*}$fc web-black Web-gold] - set val [list ansi $ansi cat alkaline_earth] - foreach e $cat_alkaline_earth { - tcl::dict::set ecat $e $val - } - - 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 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 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 black Term-orange1] - set val [list ansi $ansi cat transition_metals] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list Al Ga In Sn Tl Pb Bi Po] - set ansi [a+ {*}$fc web-black Web-lightskyblue] - set val [list ansi $ansi cat post_transition_metals] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list B Si Ge As Sb Te At] - #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 - } - - set cat [list He Ne Ar Kr Xe Rn] - set ansi [a+ {*}$fc web-black Web-orchid] - set val [list ansi $ansi cat noble_gases] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr] - set ansi [a+ {*}$fc web-black Web-plum] - set val [list ansi $ansi cat actinoids] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - 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 black Term-tan] - set val [list ansi $ansi cat lanthanoids] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set ansi [a+ {*}$fc web-black Web-whitesmoke] - set val [list ansi $ansi cat other] - foreach e [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] { - tcl::dict::set ecat $e $val - } - - set elements1 [list] - set RST [a+] - foreach e $elements { - if {[tcl::dict::exists $ecat $e]} { - set ansi [tcl::dict::get $ecat $e ansi] - #lappend elements1 [textblock::pad $ansi$e -width 2 -which right] - #no need to pad here - table column_configure -textalign default of left will do the work of padding right anyway - lappend elements1 $ansi$e - } else { - lappend elements1 $e - } - } - - set t [list_as_table -columns 19 -return tableobject $elements1] - #(defaults to show_hseps 0) - - #todo - keep simple table with symbols as base - map symbols to descriptions etc for more verbose table options - - set header_0 [list 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18] - set c 0 - foreach h $header_0 { - $t configure_column $c -headers [list $h] -minwidth 2 - incr c - } - set ccount [$t column_count] - for {set c 0} {$c < $ccount} {incr c} { - $t configure_column $c -minwidth 3 - } - if {[tcl::dict::get $opts -compact]} { - #compact defaults - but let explicit arguments override - set conf [dict create -show_vseps 0 -show_header 0 -show_edge 0] - } else { - set conf [dict create -show_vseps 1 -show_header 1 -show_edge 1] - } - dict for {k v} $conf { - if {[dict get $opts $k] ne ""} { - dict set conf $k [dict get $opts $k] - } - } - $t configure {*}[dict get $conf] - - $t configure \ - -frametype_header light\ - -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 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 - } - return $t - } - - proc list_as_table {args} { - set argd [punk::args::get_dict [string map [list $::textblock::frametypes] { - -return -default table -choices {table tableobject} - -frametype -default "" -help "frame type: or dict for custom frame" - -show_edge -default "" -type boolean -help "show outer border of table" - -show_seps -default "" -type boolean - -show_vseps -default "" -type boolean -help "Show vertical table separators" - -show_hseps -default "" -type boolean -help "Show horizontal table separators - (default 0 if no existing -table supplied)" - -table -default "" -type string -help "existing table object to use" - -headers -default "" -help "list of header values. Must match number of columns" - -show_header -default "" -help "Whether to show a header row. - Leave as empty string for unspecified/automatic, - in which case it will display only if -headers list was supplied." - -action -default "append" -choices {append replace} -help "row insertion method if existing -table is supplied - if append is chosen the new values will always start at the first column" - -columns -default "" -type integer -help "Number of table columns - Will default to 2 if not using an existing -table object" - *values -min 0 -max 1 - datalist -default {} -help "flat list of table cell values which will be wrapped based on -columns value" - }] $args] - set opts [dict get $argd opts] - set datalist [dict get $argd values datalist] - - set existing_table [dict get $opts -table] - set opt_columns [dict get $opts -columns] - #set opts [tcl::dict::create\ - # -return string\ - # -frametype \uFFEF\ - # -show_edge \uFFEF\ - # -show_seps \uFFEF\ - #] - #foreach {k v} $args { - # switch -- $k { - # -return - -show_edge - -show_seps - -frametype { - # tcl::dict::set opts $k $v - # } - # default { - # error "unrecognised option '$k'. Known options [tcl::dict::keys $opts]" - # } - # } - #} - - set count [llength $datalist] - - set is_new_table 0 - if {$existing_table ne ""} { - if {[tcl::namespace::tail [info object class $existing_table]] ne "table"} { - error "textblock::list_as_table error -table must be an existing table object (e.g set t \[textblock::class::table new\])" - } - set t $existing_table - foreach prop {-frametype -show_edge -show_seps -show_vseps -show_hseps} { - if {[tcl::dict::get $opts $prop] ne ""} { - $t configure $prop [tcl::dict::get $opts $prop] - } - } - if {[dict get $opts -action] eq "replace"} { - $t row_clear - } - set cols [$t column_count] - if {[tcl::string::is integer -strict $opt_columns]} { - if {$opt_columns > $cols} { - set extra [expr {$opt_columns - $cols}] - for {set c 0} {$c < $extra} {incr c} { - $t add_column - } - } elseif {$opt_columns < $cols} { - #todo - auto add blank values in the datalist - error "Number of columns requested: $opt_columns is less than existing number of columns $cols - not yet supported" - } - set cols [$t column_count] - } - } else { - set is_new_table 1 - set headers {} - if {[tcl::dict::get $opts -headers] ne ""} { - set headers [dict get $opts -headers] - if {[tcl::dict::get $opts -show_header] eq ""} { - set show_header 1 - } else { - set show_header [tcl::dict::get $opts -show_header] - } - } else { - if {[tcl::dict::get $opts -show_header] eq ""} { - set show_header 0 - } else { - set show_header [tcl::dict::get $opts -show_header] - } - } - - if {[tcl::string::is integer -strict $opt_columns]} { - set cols $opt_columns - if {[llength $headers] && $cols != [llength $headers]} { - error "list_as_table number of columns ($cols) doesn't match supplied number of headers ([llength $headers])" - } - } else { - #review - if {[llength $headers]} { - set cols [llength $headers] - } else { - set cols 2 ;#seems a reasonable default - } - } - #defaults for new table only - if {[tcl::dict::get $opts -frametype] eq ""} { - tcl::dict::set opts -frametype "light" - } - if {[tcl::dict::get $opts -show_edge] eq ""} { - tcl::dict::set opts -show_edge 1 - } - if {[tcl::dict::get $opts -show_seps] eq ""} { - tcl::dict::set opts -show_seps 1 - } - if {[tcl::dict::get $opts -show_vseps] eq ""} { - tcl::dict::set opts -show_vseps 1 - } - if {[tcl::dict::get $opts -show_hseps] eq ""} { - tcl::dict::set opts -show_hseps 0 - } - - set t [textblock::class::table new\ - -show_header $show_header\ - -show_edge [tcl::dict::get $opts -show_edge]\ - -frametype [tcl::dict::get $opts -frametype]\ - -show_seps [tcl::dict::get $opts -show_seps]\ - -show_vseps [tcl::dict::get $opts -show_vseps]\ - -show_hseps [tcl::dict::get $opts -show_hseps]\ - ] - if {[llength $headers]} { - for {set c 0} {$c < $cols} {incr c} { - $t add_column -headers [lindex $headers $c] - } - } else { - for {set c 0} {$c < $cols} {incr c} { - $t add_column -headers [list $c] - } - } - } - - set full_rows [expr {$count / $cols}] - set last_items [expr {$count % $cols}] - - - set rowdata [list] - set row [list] - set i 0 - if {$full_rows > 0} { - for {set r 0} {$r < $full_rows} {incr r} { - set j [expr {$i + ($cols -1)}] - set row [lrange $datalist $i $j] - incr i $cols - lappend rowdata $row - } - } - if {$last_items > 0} { - set idx [expr {$last_items -1}] - lappend rowdata [lrange $datalist end-$idx end] - } - foreach row $rowdata { - set shortfall [expr {$cols - [llength $row]}] - if {$shortfall > 0} { - set row [concat $row [lrepeat $shortfall ""]] - } - $t add_row $row - } - #puts stdout $rowdata - if {[tcl::dict::get $opts -return] eq "table"} { - set result [$t print] - if {$is_new_table} { - $t destroy - } - return $result - } else { - return $t - } - } - #return a homogenous block of characters - ie lines all same length, all same character - #printing-width in terminal columns is not necessarily same as blockwidth even if a single char is passed (could be full-width unicode character) - #This can have ansi SGR codes - but to repeat blocks containing ansi-movements, the block should first be rendered to a static output with something like overtype::left - proc block {blockwidth blockheight {char " "}} { - if {$blockwidth < 0} { - error "textblock::block blockwidth must be an integer greater than or equal to zero" - } - if {$blockheight <= 0} { - error "textblock::block blockheight must be a positive integer" - } - if {$char eq ""} {return ""} - #using tcl::string::length is ok - if {[tcl::string::length $char] == 1} { - set row [tcl::string::repeat $char $blockwidth] - set mtrx [lrepeat $blockheight $row] - return [::join $mtrx \n] - } else { - set charblock [tcl::string::map [list \r\n \n] $char] - if {[tcl::string::last \n $charblock] >= 0} { - if {$blockwidth > 1} { - #set row [.= val $charblock {*}[lrepeat [expr {$blockwidth -1}] |> piper_blockjoin $charblock]] ;#building a repeated "|> command arg" list to evaluate as a pipeline. (from before textblock::join could take arbitrary num of blocks ) - set row [textblock::join_basic -- {*}[lrepeat $blockwidth $charblock]] - } else { - set row $charblock - } - } else { - set row [tcl::string::repeat $char $blockwidth] - } - set mtrx [lrepeat $blockheight $row] - return [::join $mtrx \n] - } - } - proc testblock {size {colour ""}} { - if {$size <1 || $size > 15} { - error "textblock::testblock only sizes between 1 and 15 inclusive supported" - } - set rainbow_list [list] - lappend rainbow_list {30 47} ;#black White - lappend rainbow_list {31 46} ;#red Cyan - lappend rainbow_list {32 45} ;#green Purple - lappend rainbow_list {33 44} ;#yellow Blue - lappend rainbow_list {34 43} ;#blue Yellow - lappend rainbow_list {35 42} ;#purple Green - lappend rainbow_list {36 41} ;#cyan Red - lappend rainbow_list {37 40} ;#white Black - lappend rainbow_list {black Yellow} - lappend rainbow_list red - lappend rainbow_list green - lappend rainbow_list yellow - lappend rainbow_list blue - lappend rainbow_list purple - lappend rainbow_list cyan - lappend rainbow_list {white Red} - - set rainbow_direction "horizontal" - set vpos [lsearch $colour vertical] - if {$vpos >= 0} { - set rainbow_direction vertical - set colour [lremove $colour $vpos] - } - set hpos [lsearch $colour horizontal] - if {$hpos >=0} { - #horizontal is the default and superfluous but allowed for symmetry - set colour [lremove $colour $hpos] - } - - - - set chars [concat [punk::lib::range 1 9] A B C D E F] - set charsubset [lrange $chars 0 $size-1] - if {"noreset" in $colour} { - set RST "" - } else { - set RST [a] - } - if {"rainbow" in $colour && $rainbow_direction eq "vertical"} { - #column first - colour change each column - set c [::join $charsubset \n] - - set clist [list] - for {set i 0} {$i <$size} {incr i} { - set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $i]] $colour] - set ansi [a+ {*}$colour2] - - set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] - lappend clist ${ansicode}$c$RST - } - if {"noreset" in $colour} { - return [textblock::join_basic -ansiresets 0 -- {*}$clist] - } else { - return [textblock::join_basic -- {*}$clist] - } - } elseif {"rainbow" in $colour} { - #direction must be horizontal - set block "" - for {set r 0} {$r < $size} {incr r} { - set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $r]] $colour] - set ansi [a+ {*}$colour2] - set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] - set row "$ansicode" - foreach c $charsubset { - append row $c - } - append row $RST - append block $row\n - } - set block [tcl::string::trimright $block \n] - return $block - } else { - #row first - - set rows [list] - foreach ch $charsubset { - lappend rows [tcl::string::repeat $ch $size] - } - set block [::join $rows \n] - if {$colour ne ""} { - set block [a+ {*}$colour]$block$RST - } - return $block - } - } - interp alias {} testblock {} textblock::testblock - - #todo - consider 'elastic tabstops' for textblocks where tab acts as a column separator and adjacent lines with the same number of tabs form a sort of table - proc width {textblock} { - #backspaces, vertical tabs ? - if {$textblock eq ""} { - return 0 - } - #textutil::tabify is a reasonable hack when there are no ansi SGR codes - but probably not always what we want even then - review - if {[tcl::string::last \t $textblock] >= 0} { - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set textblock [textutil::tabify::untabify2 $textblock $tw] - } - if {[punk::ansi::ta::detect $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}]] - } - return [punk::char::ansifreestring_width $textblock] - } - #when we know the block is uniform in width - just examine topline - proc widthtopline {textblock} { - set firstnl [tcl::string::first \n $textblock] - if {$firstnl >= 0} { - set tl [tcl::string::range $textblock 0 $firstnl] - } else { - set tl $textblock - } - if {[punk::ansi::ta::detect $tl]} { - set tl [punk::ansi::ansistripraw $tl] - } - return [punk::char::ansifreestring_width $tl] - } - #uses tcl's tcl::string::length on each line. Length will include chars in ansi codes etc - this is not a 'width' determining function. - proc string_length_line_max textblock { - tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}] - } - proc string_length_line_min textblock { - tcl::mathfunc::min {*}[lmap v [split $textblock \n] {tcl::string::length $v}] - } - proc height {textblock} { - #This is the height as it will/would-be rendered - not the number of input lines purely in terms of le - #empty string still has height 1 (at least for left-right/right-left languages) - - #vertical tab on a proper terminal should move directly down. - #Whether or not the terminal in use actually does this - we need to calculate as if it does. (there might not even be a terminal) - - set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list - return [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le - } - #MAINTENANCE - same as overtype::blocksize? - proc size {textblock} { - if {$textblock eq ""} { - 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 - } - #strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack - if {[tcl::string::last \t $textblock] >= 0} { - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set textblock [textutil::tabify::untabify2 $textblock $tw] - } - #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::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}]] - set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] - } else { - set width [punk::char::ansifreestring_width $textblock] - } - set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list - #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 [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize ]] width height - } - proc size_as_opts {textblock} { - set sz [size $textblock] - return [dict create -width [dict get $sz width] -height [dict get $sz height]] - } - proc size_as_list {textblock} { - set sz [size $textblock] - return [list [dict get $sz width] [dict get $sz height]] - } - #must be able to handle block as string with or without newlines - #if no newlines - attempt to treat as a list - #must handle whitespace-only string,list elements, and/or lines. - #reviewing 2024 - this seems like too much magic! - proc width1 {block} { - if {$block eq ""} { - return 0 - } - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - 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 [ansistrip $v]}]] - } - if {[catch {llength $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 [ansistrip $v]}]] - } - - #we shouldn't make textblock depend on the punk pipeline system - #pipealias ::textblock::padleft .= {list $input [tcl::string::repeat " " $indent]} |/0,padding/1> punk:lib::lines_as_list -- |> .= {lmap v $data {overtype::right $padding $v}} |> punk::lib::list_as_lines -- punk::lib::lines_as_list -- |> .= {lmap v $data {overtype::left $padding $v}} |> punk::lib::list_as_lines -- |? ?-which right|left|centre? ?-width auto|? ?-within_ansi 1|0?" - foreach {k v} $args { - switch -- $k { - -padchar - -which - -width - -overflow - -within_ansi { - tcl::dict::set opts $k $v - } - default { - error "textblock::pad unrecognised option '$k'. Usage: $usage" - } - } - } - # -- --- --- --- --- --- --- --- --- --- - set padchar [tcl::dict::get $opts -padchar] - #if padchar width (screen width) > 1 - length calculations will not be correct - #we will allow tokens longer than 1 - as the caller may want to post-process on the token whilst preserving previous leading/trailing spaces, e.g with a tcl::string::map - #The caller may also use ansi within the padchar - although it's unlikely to be efficient. - # -- --- --- --- --- --- --- --- --- --- - set known_whiches [list l left r right c center centre] - set opt_which [tcl::string::tolower [tcl::dict::get $opts -which]] - switch -- $opt_which { - center - centre - c { - set which c - } - left - l { - set which l - } - right - r { - set which r - } - default { - error "textblock::pad unrecognised value for -which option. Known values $known_whiches" - } - } - # -- --- --- --- --- --- --- --- --- --- - set opt_width [tcl::dict::get $opts -width] - switch -- $opt_width { - "" - auto { - set width auto - } - default { - if {![tcl::string::is integer -strict $opt_width] || $opt_width < 0} { - error "textblock::pad -width must be an integer >=0" - } - set width $opt_width - } - } - # -- --- --- --- --- --- --- --- --- --- - set opt_withinansi [tcl::dict::get $opts -within_ansi] - switch -- $opt_withinansi { - 0 - 1 {} - default { - set opt_withinansi 2 - } - } - # -- --- --- --- --- --- --- --- --- --- - - set datawidth [textblock::width $block] - if {$width eq "auto"} { - set width $datawidth - } - - 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 - 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? - #experimental fallback to supposedly faster simpler 'format' but we still need to compensate for double-width or non-printing chars - and it won't work on strings with ansi SGR codes - if 0 { - #review - surprisingly, this doesn't seem to be a performance win - #No detectable diff on small blocks - slightly worse on large blocks - if {($padchar eq " " || $padchar eq "0") && ![punk::ansi::ta::detect $block]} { - #This will still be wrong for example with diacritics on terminals that don't collapse the space following a diacritic, and don't correctly report cursor position - #(i.e as at 2024 - lots of them) wezterm on windows at least does the right thing. - set block [tcl::string::map [list \r\n \n] $block] - if {$which eq "l"} { - set fmt "%+${padchar}*s" - } else { - set fmt "%-${padchar}*s" - } - foreach ln [split $block \n] { - #set lnwidth [punk::char::ansifreestring_width $ln] - set lnwidth [punk::char::grapheme_width_cached $ln] - set lnlen [tcl::string::length $ln] - set diff [expr $lnwidth - $lnlen] - #we need trickwidth to get format to pad a string with a different terminal width compared to string length - set trickwidth [expr {$width - $diff}] ;#may 'subtract' a positive or negative int (ie will add to trickwidth if negative) - lappend lines [format $fmt $trickwidth $ln] - } - return [::join $lines \n] - } - } - - #todo? special case trailing double-reset - insert between resets? - set lnum 0 - if {[punk::ansi::ta::detect $block]} { - set parts [punk::ansi::ta::split_codes $block] - } else { - #single plaintext part - set parts [list $block] - } - 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}] - if {$has_nl} { - set pt [tcl::string::map [list \r\n \n] $pt] - set partlines [split $pt \n] - } else { - set partlines [list $pt] - } - set last [expr {[llength $partlines]-1}] - set p 0 - 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 - REVIEW - if {$p != $last} { - #do padding - set missing [expr {$width - $line_len}] - if {$missing > 0} { - #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 - } - r-1 { - if {[lindex $line_chunks end] eq ""} { - set line_chunks [linsert $line_chunks end-2 $pad] - } else { - lappend line_chunks $pad - } - } - r-2 { - lappend line_chunks $pad - } - l-0 { - set line_chunks [linsert $line_chunks 0 $pad] - } - l-1 { - if {[lindex $line_chunks 0] eq ""} { - set line_chunks [linsert $line_chunks 2 $pad] - } else { - set line_chunks [linsert $line_chunks 0 $pad] - } - } - l-2 { - if {$lnum == 0} { - if {[lindex $line_chunks 0] eq ""} { - set line_chunks [linsert $line_chunks 2 $pad] - } else { - set line_chunks [linsert $line_chunks 0 $pad] - } - } else { - set line_chunks [linsert $line_chunks 0 $pad] - } - } - } - } - lappend lines [::join $line_chunks ""] - set line_chunks [list] - set line_len 0 - incr lnum - } - incr p - } - } else { - #we need to store empties in order to insert text in the correct position relative to leading/trailing ansi codes - lappend line_chunks "" - } - #don't let trailing empty ansi affect the line_chunks length - if {$ansi ne ""} { - lappend line_chunks $ansi ;#don't update line_len - review - ansi codes with visible content? - } - } - #pad last line - set missing [expr {$width - $line_len}] - if {$missing > 0} { - 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 - } - r-1 { - if {[lindex $line_chunks end] eq ""} { - set line_chunks [linsert $line_chunks end-2 $pad] - } else { - lappend line_chunks $pad - } - } - r-2 { - if {[lindex $line_chunks end] eq ""} { - set line_chunks [linsert $line_chunks end-2 $pad] - } else { - lappend line_chunks $pad - } - #lappend line_chunks $pad - } - l-0 { - #if {[lindex $line_chunks 0] eq ""} { - # set line_chunks [linsert $line_chunks 2 $pad] - #} else { - # set line_chunks [linsert $line_chunks 0 $pad] - #} - set line_chunks [linsert $line_chunks 0 $pad] - } - l-1 { - #set line_chunks [linsert $line_chunks 0 $pad] - set line_chunks [_insert_before_text_or_last_ansi $pad $line_chunks] - } - l-2 { - set line_chunks [linsert $line_chunks 0 $pad] - } - } - } - lappend lines [::join $line_chunks ""] - return [::join $lines \n] - } - - #left insertion into a list resulting from punk::ansi::ta::split_codes or split_codes_single - #resulting list is no longer a valid ansisplit list - proc _insert_before_text_or_last_ansi {str ansisplits} { - if {[llength $ansisplits] == 1} { - #ansisplits was a split on plaintext only - return [list $str [lindex $ansisplits 0]] - } elseif {[llength $ansisplits] == 0} { - return [list $str] - } - if {[llength $ansisplits] %2 != 1} { - error "_insert_before_text_or_last_ansi ansisplits list is not a valid resultlist from an ansi split - must be odd number of elements pt,ansi,pt,ansi...pt" - } - set out [list] - set i 0 - set i_last_code [expr {[llength $ansisplits]-3}] ;#would normally be -2 - but our i is jumping to each pt - not every element - foreach {pt code} $ansisplits { - if {$pt ne ""} { - return [lappend out $str {*}[lrange $ansisplits $i end]] - } - if {$i == $i_last_code} { - return [lappend out $str {*}[lrange $ansisplits $i end]] - } - #code being empty can only occur when we have reached last pt - #we have returned by then. - lappend out $code - incr i 2 - } - error "_insert_before_text_or_last_ansi failed on input str:[ansistring VIEW $str] ansisplits:[ansistring VIEW $ansisplits]" - } - proc pad_test {block} { - set width [textblock::width $block] - set padtowidth [expr {$width + 10}] - set left0 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 0] - set left1 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 1] - set left2 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 2] - set right0 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 0] - set right1 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 1] - set right2 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 2] - - set testlist [list "within_ansi 0" $left0 $right0 "within_ansi 1" $left1 $right1 "within_ansi 2" $left2 $right2] - - set t [textblock::list_as_table -columns 3 -return tableobject $testlist] - $t configure_column 0 -headers [list "ansi"] - $t configure_column 1 -headers [list "Left"] - $t configure_column 2 -headers [list "Right"] - $t configure -show_header 1 - puts stdout [$t print] - return $t - } - - proc pad_test_blocklist {blocklist args} { - set opts [tcl::dict::create\ - -description ""\ - -blockheaders ""\ - ] - foreach {k v} $args { - switch -- $k { - -description - -blockheaders { - tcl::dict::set opts $k $v - } - default { - error "pad_test_blocklist unrecognised option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - set opt_blockheaders [tcl::dict::get $opts -blockheaders] - set bheaders [tcl::dict::create] - if {$opt_blockheaders ne ""} { - set b 0 - foreach h $opt_blockheaders { - if {$b < [llength $blocklist]} { - tcl::dict::set bheaders $b $h - } - incr b - } - } - - set b 0 - set blockinfo [tcl::dict::create] - foreach block $blocklist { - set width [textblock::width $block] - tcl::dict::set blockinfo $b width $width - set padtowidth [expr {$width + 3}] - tcl::dict::set blockinfo $b left0 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 0] - tcl::dict::set blockinfo $b left1 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 1] - tcl::dict::set blockinfo $b left2 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 2] - tcl::dict::set blockinfo $b right0 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 0] - tcl::dict::set blockinfo $b right1 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 1] - tcl::dict::set blockinfo $b right2 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 2] - incr b - } - - set r0 [list "0"] - set r1 [list "1"] - set r2 [list "2"] - set r3 [list "column\ncolours"] - - #1 - #test without table padding - #we need to textblock::join each item to ensure we don't get the table's own textblock::pad interfering - #(basically a mechanism to add extra resets at start and end of each line) - #dict for {b bdict} $blockinfo { - # lappend r0 [textblock::join [tcl::dict::get $blockinfo $b left0]] [textblock::join [tcl::dict::get $blockinfo $b right0]] - # lappend r1 [textblock::join [tcl::dict::get $blockinfo $b left1]] [textblock::join [tcl::dict::get $blockinfo $b right1]] - # lappend r2 [textblock::join [tcl::dict::get $blockinfo $b left2]] [textblock::join [tcl::dict::get $blockinfo $b right2]] - #} - - #2 - the more useful one? - tcl::dict::for {b bdict} $blockinfo { - lappend r0 [tcl::dict::get $blockinfo $b left0] [tcl::dict::get $blockinfo $b right0] - lappend r1 [tcl::dict::get $blockinfo $b left1] [tcl::dict::get $blockinfo $b right1] - lappend r2 [tcl::dict::get $blockinfo $b left2] [tcl::dict::get $blockinfo $b right2] - lappend r3 "" "" - } - - set rows [concat $r0 $r1 $r2 $r3] - - set column_ansi [a+ web-white Web-Gray] - - set t [textblock::list_as_table -columns [expr {1 + (2 * [tcl::dict::size $blockinfo])}] -return tableobject $rows] - $t configure_column 0 -headers [list [tcl::dict::get $opts -description] "within_ansi"] -ansibase $column_ansi - set col 1 - tcl::dict::for {b bdict} $blockinfo { - if {[tcl::dict::exists $bheaders $b]} { - set hdr [tcl::dict::get $bheaders $b] - } else { - set hdr "Block $b" - } - $t configure_column $col -headers [list $hdr "Left"] -minwidth [expr {$padtowidth + 2}] - $t configure_column $col -header_colspans 2 -ansibase $column_ansi - incr col - $t configure_column $col -headers [list "-" "Right"] -minwidth [expr {$padtowidth + 2}] -ansibase $column_ansi - incr col - } - $t configure -show_header 1 - puts stdout [$t print] - return $t - } - proc pad_example {} { - set headers [list] - set blocks [list] - - lappend blocks "[textblock::testblock 4 rainbow]" - lappend headers "rainbow 4x4\nresets at line extremes\nnothing trailing" - - lappend blocks "[textblock::testblock 4 rainbow][a]" - lappend headers "rainbow 4x4\nresets at line extremes\ntrailing reset" - - lappend blocks "[textblock::testblock 4 rainbow]\n[a+ Web-Green]" - lappend headers "rainbow 4x4\nresets at line extremes\ntrailing nl&green bg" - - lappend blocks "[textblock::testblock 4 {rainbow noreset}]" - lappend headers "rainbow 4x4\nno line resets\nnothing trailing" - - lappend blocks "[textblock::testblock 4 {rainbow noreset}][a]" - lappend headers "rainbow 4x4\nno line resets\ntrailing reset" - - lappend blocks "[textblock::testblock 4 {rainbow noreset}]\n[a+ Web-Green]" - lappend headers "rainbow 4x4\nno line resets\ntrailing nl&green bg" - - set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] - } - proc pad_example2 {} { - set headers [list] - set blocks [list] - lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n" - lappend headers "red on blue 4x4\nno inner resets\ntrailing nl" - - lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a]" - lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&reset" - - lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a+ Web-Green]" - lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&green bg" - - set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] - } - - - #playing with syntax - - # pipealias ::textblock::join_width .= {list $lhs [tcl::string::repeat " " $w1] $rhs [tcl::string::repeat " " $w2]} {| - # /2,col1/1,col2/3 - # >} punk::lib::lines_as_list -- {| - # data2 - # >} .=lhs> punk::lib::lines_as_list -- {| - # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| - # >} punk::lib::list_as_lines -- } .=> punk::lib::lines_as_list -- {| - # data2 - # >} .=lhs> punk::lib::lines_as_list -- {| - # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| - # >} punk::lib::list_as_lines -- } .=> punk::lib::lines_as_list -- {| - # data2 - # >} .=lhs> punk::lib::lines_as_list -- {| - # >} .= {lmap v $data w $data2 {val "[overtype::right $col1 $v][overtype::right $col2 $w]"}} {| - # >} punk::lib::list_as_lines punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a] - set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks] - set testblock [textblock::testblock 15 rainbow] - set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks] - set framed [textblock::frame -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents] - } - - - proc example {args} { - set opts [tcl::dict::create -forcecolour 0] - foreach {k v} $args { - switch -- $k { - -forcecolour { - tcl::dict::set opts $k $v - } - default { - error "textblock::example unrecognised option '$k'. Known-options: [tcl::dict::keys $opts]" - } - } - } - set opt_forcecolour 0 - if {[tcl::dict::get $opts -forcecolour]} { - set fc forcecolour - set opt_forcecolour 1 - } else { - set fc "" - } - set pleft [>punk . rhs] - set pright [>punk . lhs] - set prightair [>punk . lhs_air] - set red [a+ {*}$fc red]; set redb [a+ {*}$fc red bold] - set green [a+ {*}$fc green]; set greenb [a+ {*}$fc green bold] - set cyan [a+ {*}$fc cyan];set cyanb [a+ {*}$fc cyan bold] - set blue [a+ {*}$fc blue];set blueb [a+ {*}$fc blue bold] - set RST [a] - set gr0 [punk::ansi::g0 abcdefghijklm\nnopqrstuvwxyz] - set punks [textblock::join -- $pleft $pright] - set pleft_greenb $greenb$pleft$RST - set pright_redb $redb$pright$RST - set prightair_cyanb $cyanb$prightair$RST - set cpunks [textblock::join -- $pleft_greenb $pright_redb] - set out "" - append out $punks \n - append out $cpunks \n - append out [textblock::join -- $punks $cpunks] \n - set 2frames_a [textblock::join -- [textblock::frame $cpunks] [textblock::frame $punks]] - append out $2frames_a \n - set 2frames_b [textblock::join -- [textblock::frame -ansiborder $cyanb -title "plainpunks" $punks] [textblock::frame -ansiborder $greenb -title "fancypunks" $cpunks]] - append out [textblock::frame -title "punks" $2frames_b\n$RST$2frames_a] \n - set fancy [overtype::right [overtype::left [textblock::frame -ansiborder [a+ green bold] -type heavy -title ${redb}PATTERN$RST -subtitle ${redb}PUNK$RST $prightair_cyanb] "$blueb\n\n\P\nU\nN\nK$RST"] "$blueb\n\nL\nI\nF\nE"] - set spantable [[spantest] print] - append out [textblock::join -- $fancy " " $spantable] \n - #append out [textblock::frame -title gr $gr0] - append out [textblock::periodic -forcecolour $opt_forcecolour] - return $out - } - - 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 " | "]] - } - 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]\ - " "\ - $text\ - [>punk . rhs]\ - [punk::lib::list_as_lines -- [lrepeat 8 " | "]] - } - proc table {args} { - #todo - use punk::args - upvar ::textblock::class::opts_table_defaults toptdefaults - set defaults [tcl::dict::create\ - -rows [list]\ - -headers [list]\ - -return string\ - ] - - - set defaults [tcl::dict::merge $defaults $toptdefaults] ;# -title -frametype -show_header etc - set opts [tcl::dict::merge $defaults $args] - # -- --- --- --- - set opt_return [tcl::dict::get $opts -return] - set opt_rows [tcl::dict::get $opts -rows] - set opt_headers [tcl::dict::get $opts -headers] - # -- --- --- --- - set topts [tcl::dict::create] - set toptkeys [tcl::dict::keys $toptdefaults] - tcl::dict::for {k v} $opts { - if {$k in $toptkeys} { - tcl::dict::set topts $k $v - } - } - set t [textblock::class::table new {*}$topts] - - foreach h $opt_headers { - $t add_column -headers [list $h] - } - if {[$t column_count] == 0} { - if {[llength $opt_rows]} { - set r0 [lindex $opt_rows 0] - foreach c $r0 { - $t add_column - } - } - } - foreach r $opt_rows { - $t add_row $r - } - - - - if {$opt_return eq "string"} { - set result [$t print] - $t destroy - return $result - } else { - return $t - } - } - - variable frametypes - set frametypes [list light heavy arc double block block1 block2 block2hack ascii altg] - #class::table needs to be able to determine valid frametypes - proc frametypes {} { - variable frametypes - return $frametypes - } - proc frametype {f} { - #set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] - switch -- $f { - light - heavy - arc - double - block - block1 - block2 - block2hack - 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 - } - 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] - } - } - } - variable framedef_cache [tcl::dict::create] - 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 $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\ - ] - set bad_option 0 - foreach {k v} $argopts { - switch -- $k { - -joins - -boxonly { - tcl::dict::set opts $k $v - } - default { - 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 -choices "" -choiceprefix 0 -help "name from the predefined frametypes - or an adhoc dictionary." - }] - #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] - - - #sorted order down left right up - #1 x choose 4 - #4 x choose 3 - #6 x choose 2 - #4 x choose 1 - #15 combos - - set join_directions [list] - #targets - light,heavy (double?) - seem to be some required glyphs missing from unicode - #e.g down-light, up-heavy - set join_targets [tcl::dict::create left "" down "" right "" up ""] - foreach jt $joins { - lassign [split $jt -] direction target - if {$target ne ""} { - tcl::dict::set join_targets $direction $target - } - lappend join_directions $direction - } - set join_directions [lsort -unique $join_directions] - set do_joins [::join $join_directions _] - - - switch -- $f { - "altg" { - #old style ansi escape sequences with alternate graphics page G0 - set hl [cd::hl] - set hlt $hl - set hlb $hl - set vl [cd::vl] - set vll $vl - set vlr $vl - set tlc [cd::tlc] - set trc [cd::trc] - set blc [cd::blc] - set brc [cd::brc] - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - #No join targets available to join altg to other box styles - switch -- $do_joins { - down { - #1 - set blc [punk::ansi::g0 t] ;#(ltj) - set brc [punk::ansi::g0 u] ;#(rtj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } left { - #2 - set tlc [punk::ansi::g0 w] ;#(ttj) - set blc [punk::ansi::g0 v] ;#(btj) - set vllj [punk::ansi::g0 u] ;#(rtj) - } - right { - #3 - set trc [punk::ansi::g0 w] ;#(ttj) - set brc [punk::ansi::g0 v] ;#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - up { - #4 - set tlc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 u] ;#(rtj) - set hltj [punk::ansi::g0 v];#(btj) - } - down_left { - #5 - set blc [punk::ansi::g0 n] ;#(fwj) - set tlc [punk::ansi::g0 w] ;#(ttj) - set brc [punk::ansi::g0 u] ;#(rtj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - set vllj [punk::ansi::g0 u] ;#(rtj) - } - down_right { - #6 - set blc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 w] ;#(ttj) - set brc [punk::ansi::g0 n] ;#(fwj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - down_up { - #7 - set blc [punk::ansi::g0 t] ;#(ltj) - set brc [punk::ansi::g0 u] ;#(rtj) - - set tlc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 u] ;#(rtj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - set hltj [punk::ansi::g0 v];#(btj) - } - left_right { - #8 - #from 2 - set tlc [punk::ansi::g0 w] ;#(ttj) - set blc [punk::ansi::g0 v] ;#(btj) - #from3 - set trc [punk::ansi::g0 w] ;#(ttj) - set brc [punk::ansi::g0 v] ;#(btj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - left_up { - #9 - set tlc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 u] ;#(rtj) - set blc [punk::ansi::g0 v] ;#(btj) - set vllj [punk::ansi::g0 u] ;#(rtj) - } - right_up { - #10 - set tlc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 n] ;#(fwj) - set brc [punk::ansi::g0 v] ;#(btj) - set hltj [punk::ansi::g0 v];#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - down_left_right { - #11 - set blc [punk::ansi::g0 n] ;#(fwj) - set brc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 w] ;#(ttj) - set tlc [punk::ansi::g0 w] ;#(ttj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } - down_left_up { - #12 - set tlc [punk::ansi::g0 n] ;#(fwj) - set blc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 u] ;#(rtj) - set brc [punk::ansi::g0 u] ;#(rtj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set hltj [punk::ansi::g0 v];#(btj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } - down_right_up { - #13 - set tlc [punk::ansi::g0 t] ;#(ltj) - set blc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 n] ;#(fwj) - set brc [punk::ansi::g0 n] ;#(fwj) - set hltj [punk::ansi::g0 v];#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } - left_right_up { - #14 - set tlc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 n] ;#(fwj) - set blc [punk::ansi::g0 v] ;#(btj) - set brc [punk::ansi::g0 v] ;#(btj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set hltj [punk::ansi::g0 v];#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - down_left_right_up { - #15 - set tlc [punk::ansi::g0 n] ;#(fwj) - set blc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 n] ;#(fwj) - set brc [punk::ansi::g0 n] ;#(fwj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set hltj [punk::ansi::g0 v];#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } - } - - - } - "ascii" { - set hl - - set hlt - - set hlb - - set vl | - set vll | - set vlr | - set tlc + - set trc + - set blc + - set brc + - #horizontal and vertical bar joins - #set hltj $hlt - #set hlbj $hlb - #set vllj $vll - #set vlrj $vlr - #ascii + is small - can reasonably be considered a join to anything? - set hltj + - set hlbj + - set vllj + - set vlrj + - #our corners are all + already - so we won't do anything for directions or targets - - } - "light" { - #unicode box drawing set - set hl [punk::char::charshort boxd_lhz] ;# light horizontal - set hlt $hl - set hlb $hl - set vl [punk::char::charshort boxd_lv] ;#light vertical - set vll $vl - set vlr $vl - set tlc [punk::char::charshort boxd_ldr] - set trc [punk::char::charshort boxd_ldl] - set blc [punk::char::charshort boxd_lur] - set brc [punk::char::charshort boxd_lul] - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - #15 combos - #sort order: down left right up - #ltj,rtj,ttj,btj e.g left T junction etc. - #Look at from the perspective of a frame/table outline with a clean border and arms pointing inwards - - #set targetdown,targetleft,targetright,targetup vars - #default empty targets to current box type 'light' - foreach dir {down left right up} { - set target [tcl::dict::get $join_targets $dir] - switch -- $target { - "" - light { - set target$dir light - } - ascii - altg - arc { - set target$dir light - } - heavy { - set target$dir $target - } - default { - set target$dir other - } - } - } - switch -- $do_joins { - down { - #1 - switch -- $targetdown { - heavy { - set blc [punk::char::charshort boxd_dhrul] ;#\u251f down hieavy and right up light (ltj) - set brc \u2527 ;#boxd_dhlul down heavy and left up light (rtj) - set hlbj \u2530 ;# down heavy (ttj) - } - light { - set blc \u251c ;#[punk::char::charshort boxd_lvr] light vertical and right (ltj) - set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - set hlbj \u252c ;# (ttj) - } - } - } - left { - #2 - switch -- $targetleft { - heavy { - set tlc \u252d ;# Left Heavy and Right Down Light (ttj) - set blc \u2535 ;# Left Heavy and Right Up Light (btj) - set vllj \u2525 ;# left heavy (rtj) - } - light { - set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - joinleft - set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - set vllj \u2524 ;# (rtj) - } - } - } - right { - #3 - switch -- $targetright { - heavy { - set trc \u252e ;#Right Heavy and Left Down Light (ttj) - set brc \u2536 ;#Right Heavy and Left up Light (btj) - set vlrj \u251d;#right heavy (ltj) - } - light { - set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - set vlrj \u251c;# (ltj) - } - } - } - up { - #4 - switch -- $targetup { - heavy { - set tlc \u251e ;#up heavy (ltj) - set trc \u2526 ;#up heavy (rtj) - } - light { - set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - } - } - } - down_left { - #5 - switch -- $targetdown-$targetleft { - other-light { - set blc \u2534 ;#(btj) - set tlc \u252c ;#(ttj) - #brc - default corner - set vllj \u2524 ;# (rtj) - } - other-other { - #default corners - } - other-heavy { - set blc \u2535 ;# heavy left (btj) - set tlc \u252d ;#heavy left (ttj) - #brc default corner - set vllj \u2525 ;# heavy left (rtj) - } - heavy-light { - set blc \u2541 ;# heavy down (fwj) - set tlc \u252c ;# light (ttj) - set brc \u2527 ;# heavy down (rtj) - set vllj \u2524 ;# (rtj) - set hlbj \u2530 ;# heavy down (ttj) - } - heavy-other { - set blc \u251f ;#heavy down (ltj) - #tlc - default corner - set brc \u2527 ;#heavy down (rtj) - set hlbj \u2530 ;# heavy down (ttj) - } - heavy-heavy { - set blc \u2545 ;#heavy down and left (fwj) - set tlc \u252d ;#heavy left (ttj) - set brc \u2527 ;#heavy down (rtj) - set vllj \u2525 ;# heavy left (rtj) - set hlbj \u2530 ;# heavy down (ttj) - } - light-light { - set blc \u253c ;# [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set tlc \u252c ;# boxd_ldhz (ttj) - set brc \u2524 ;# boxd_lvl light vertical and left(rtj) - set vllj \u2524 ;# (rtj) - set hlbj \u252c ;# (ttj) - } - light-other { - set blc \u251c ;# (ltj) - #tlc - default corner - set brc \u2524 ;# boxd_lvl (rtj) - set hlbj \u252c ;# (ttj) - } - light-heavy { - set blc \u253d ;# heavy left (fwj) - set tlc \u252d ;# heavy left (ttj) - set brc \u2524 ;# light (rtj) - set vllj \u2525 ;# heavy left (rtj) - set hlbj \u252c ;# (ttj) - } - default { - set blc \u253c ;# [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set tlc \u252c ;# [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set brc \u2524 ;# [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - } - } - } - down_right { - #6 - set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - } - down_up { - #7 - set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - - set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - } - left_right { - #8 - #from 2 - set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - joinleft - set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - #from3 - set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - } - left_up { - #9 - set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - } - right_up { - #10 - set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - } - down_left_right { - #11 - set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - - } - down_left_up { - #12 - set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - - } - down_right_up { - #13 - set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - } - left_right_up { - #14 - set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - - } - down_left_right_up { - #15 - set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - } - } - #four way junction (cd::fwj) (punk::ansi::g0 n) (punk::char::charshort lvhz) (+) - } - "heavy" { - #unicode box drawing set - set hl [punk::char::charshort boxd_hhz] ;# light horizontal - set hlt $hl - set hlb $hl - set vl [punk::char::charshort boxd_hv] ;#light vertical - set vll $vl - set vlr $vl - set tlc [punk::char::charshort boxd_hdr] - set trc [punk::char::charshort boxd_hdl] - set blc [punk::char::charshort boxd_hur] - set brc [punk::char::charshort boxd_hul] - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - #set targetdown,targetleft,targetright,targetup vars - #default empty targets to current box type 'heavy' - foreach dir {down left right up} { - set target [tcl::dict::get $join_targets $dir] - switch -- $target { - "" - heavy { - set target$dir heavy - } - light - ascii - altg - arc { - set target$dir light - } - default { - set target$dir other - } - } - } - switch -- $do_joins { - down { - #1 - switch -- $targetdown { - light { - set blc [punk::char::charshort boxd_dlruh] ;#\u2521 down light and right up heavy (ltj) - set brc [punk::char::charshort boxd_dlluh] ;#\u2529 down light and left up heavy (rtj) - set hlbj \u252F ;#down light (ttj) - } - heavy { - set blc [punk::char::charshort boxd_hvr] ;# (ltj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - set hlbj \u2533 ;# down heavy (ttj) - } - } - } - left { - #2 - switch -- $targetleft { - light { - set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) - set blc [punk::char::charshort boxd_llruh] ;#\u253a Left Light and Right Up Heavy (btj) - set vllj \u2528 ;# left light (rtj) - } - heavy { - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - set vllj \u252b ;#(rtj) - } - } - } - right { - #3 - switch -- $targetright { - light { - set trc [punk::char::charshort boxd_rlldh] ;#\u2531 Right Light and Left Down Heavy (ttj) - set brc [punk::char::charshort boxd_rlluh] ;#\u2539 Right Light and Left Up Heavy(btj) - set vlrj \u2520 ;#right light (ltj) - } - heavy { - set trc [punk::char::charshort boxd_hdhz] ;#T shape (ttj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - set vlrj \u2523 ;# (ltj) - } - } - } - up { - #4 - switch -- $targetup { - light { - set tlc [punk::char::charshort boxd_ulrdh] ;#\u2522 Up Light and Right Down Heavy (ltj) - set trc [punk::char::charshort boxd_ulldh] ;#\u252a Up Light and Left Down Heavy (rtj) - set hltj \u2537 ;# up light (btj) - } - heavy { - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set hltj \u253b ;# (btj) - } - } - } - down_left { - #down_left is the main join type used for 'L' shaped cell border table building where we boxlimit to {vll hlb blc} - #5 - switch -- down-$targetdown-left-$targetleft { - down-light-left-heavy { - set blc [punk::char::charshort boxd_dluhzh] ;#down light and up horizontal heavy (fwj) - set brc [punk::char::charshort boxd_dlluh] ;#\u2529 down light and left up heavy (rtj) - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) (at tlc down stays heavy) - set hlbj \u252F ;# down light (ttj) - set vllj \u252b ;#(rtj) - } - down-heavy-left-light { - set blc [punk::char::charshort boxd_llrvh] ;# left light and right Vertical Heavy (fwj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) (at brc left must stay heavy) - set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) - set hlbj \u2533 ;# down heavy (ttj) - set vllj \u2528 ;# left light (rtj) - } - down-light-left-light { - set blc [punk::char::charshort boxd_ruhldl] ;#\u2544 right up heavy and left down light (fwj) - set brc [punk::char::charshort boxd_dlluh] ;#\u2529 Down Light and left Up Heavy (rtj) (left must stay heavy) - set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) (we are in heavy - so down must stay heavy at tlc) - set hlbj \u252F ;# down light (ttj) - set vllj \u2528 ;# left light (rtj) - } - down-heavy-left-heavy { - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set hlbj \u2533 ;#(ttj) - set vllj \u252b ;#(rtj) - } - down-other-left-heavy { - set blc \u253b ;#boxd_huhz Heavy Up and Horizontal (btj) - #leave brc default corner - set tlc \u2533 ;#hdhz Heavy Down and Horizontal (ttj) - - set vllj \u252b ;#(rtj) - } - down-other-left-light { - set blc \u253a ;#llruh Left Light and Right Up Heavy (btj) - #leave brc default corner - set tlc \u2532 ;#llrdh Left Light and Right Down Heavy (ttj) - - set vllj \u2528 ;# left light (rtj) - } - down-heavy-left-other { - set blc \u2523 ;#hvr Heavy Vertical and Right (ltj) - set brc \u252b ;#hvl Heavy Veritcal and Left (rtj) - #leave tlc default corner - - set hlbj \u2533 ;#(ttj) - } - down-light-left-other { - set blc \u2521 ;#dlruh Down Light and Right Up Heavy (ltj) - set brc \u2529 ;#dlluh Down Light and Left Up Heavy (rtj) - #leave tlc default corner - - set hlbj \u252F ;# down light (ttj) - } - } - } - down_right { - #6 - set blc [punk::char::charshort boxd_hvr] ;# (ltj) (blc right&up stay heavy) - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) (tlc down&left stay heavy) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) (brc left&up heavy) - } - down_up { - #7 - set blc [punk::char::charshort boxd_hvr] ;# (ltj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - } - left_right { - #8 - #from 2 - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - #from3 - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - } - left_up { - #9 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - } - right_up { - #10 - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - } - down_left_right { - #11 - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - - } - down_left_up { - #12 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - - } - down_right_up { - #13 - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set blc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - } - left_right_up { - #14 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - - } - down_left_right_up { - #15 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - } - } - } - "double" { - #unicode box drawing set - set hl [punk::char::charshort boxd_dhz] ;# double horizontal \U2550 - set hlt $hl - set hlb $hl - set vl [punk::char::charshort boxd_dv] ;#double vertical \U2551 - set vll $vl - set vlr $vl - set tlc [punk::char::charshort boxd_ddr] ;#double down and right \U2554 - set trc [punk::char::charshort boxd_ddl] ;#double down and left \U2557 - set blc [punk::char::charshort boxd_dur] ;#double up and right \U255A - set brc [punk::char::charshort boxd_dul] ;#double up and left \U255D - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - # \u256c (fwj) - - #set targetdown,targetleft,targetright,targetup vars - #default empty targets to current box type 'double' - foreach dir {down left right up} { - set target [tcl::dict::get $join_targets $dir] - switch -- $target { - "" - double { - set target$dir double - } - light { - set target$dir light - } - default { - set target$dir other - } - } - } - - #unicode provides no joining for double to anything else - #better to leave a gap by using default double corners if join target is not empty or double - switch -- $do_joins { - down { - #1 - switch -- $targetdown { - double { - set blc \u2560 ;# (ltj) - set brc \u2563 ;# (rtj) - set hlbj \u2566 ;# (ttj) - } - light { - set hlbj \u2564 ;# down light (ttj) - } - } - } - left { - #2 - switch -- $targetleft { - double { - set tlc \u2566 ;# (ttj) - set blc \u2569 ;# (btj) - set vllj \u2563 ;# (rtj) - } - light { - set vllj \u2562 ;# light left (rtj) - } - } - } - right { - #3 - switch -- $targetright { - double { - set trc \u2566 ;# (ttj) - set brc \u2569 ;# (btj) - } - light { - set vlrj \u255F ;# light right (ltj) - } - } - } - up { - #4 - switch -- $targetup { - double { - set tlc \u2560 ;# (ltj) - set trc \u2563 ;# (rtj) - set hltj \u2569 ;# (btj) - } - light { - set hltj \u2567 ;#up light (btj) - } - } - } - down_left { - #5 - switch -- $targetdown-$targetleft { - double-double { - set blc \u256c ;# (fwj) - set brc \u2563 ;# (rtj) - set tlc \u2566 ;# (ttj) - set hlbj \u2566 ;# (ttj) - } - double-light { - #no corner joins treat corners like 'other' - set blc \u2560 ;# (ltj) - set brc \u2563 ;# (rtj) - - set hlbj \u2566 ;# (ttj) - set vllj \u2562 ;# light left (rtj) - - } - double-other { - set blc \u2560 ;# (ltj) - set brc \u2563 ;# (rtj) - #leave tlc as ordinary double corner - } - light-double { - - set vllj \u2563 ;# (rtj) - set hlbj \u2564 ;# light down (ttj) - - } - light-light { - - set vllj \u2562 ;# light left (rtj) - set hlbj \u2564 ;# light down (ttj) - } - other-light { - set vllj \u2562 ;# light left (rtj) - } - other-double { - set blc \u2569 ;# (btj) - #leave brc as ordinary double corner - set tlc \u2566 ;# (ttj) - } - } - } - down_right { - #6 - switch -- $targetdown-$targetright { - double-double { - set blc \u2560 ;# (ltj) - set trc \u2566 ;# (ttj) - set brc \u256c ;# (fwj) - set hlbj \u2566 ;# (ttj) - } - double-other { - set blc \u2560 ;# (ltj) - #leave trc default - set brc \u2563 ;# (rtj) - } - other-double { - #leave blc default - set trc \u2566 ;# (ttj) - set brc \u2569 ;#(btj) - } - } - } - down_up { - #7 - switch -- $targetdown-$targetup { - double-double { - set blc \u2560 ;# (ltj) - set brc \u2563 ;# (rtj) - set tlc \u2560 ;# (ltj) - set trc \u2563 ;# (rtj) - set hltj \u2569 ;# (btj) - set hlbj \u2566 ;# (ttj) - } - } - } - left_right { - #8 - - #from 2 - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - #from3 - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - } - left_up { - #9 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - set hltj \u2569 ;# (btj) - set vllj \u2563 ;# (rtj) - } - right_up { - #10 - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - set hltj \u2569 ;# (btj) - set vlrj \u2560 ;# (ltj) - } - down_left_right { - #11 - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set hlbj \u2566 ;# (ttj) - set vlrj \u2560 ;# (ltj) - - } - down_left_up { - #12 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - set hltj \u2569 ;# (btj) - set hlbj \u2566 ;# (ttj) - - } - down_right_up { - #13 - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set blc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - set hltj \u2569 ;# (btj) - set hlbj \u2566 ;# (ttj) - } - left_right_up { - #14 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - set hltj \u2569 ;# (btj) - - } - down_left_right_up { - #15 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - set hltj \u2569 ;# (btj) - set hlbj \u2566 ;# (ttj) - } - } - - } - "arc" { - #unicode box drawing set - - - set hl [punk::char::charshort boxd_lhz] ;# light horizontal - set hlt $hl - set hlb $hl - set vl [punk::char::charshort boxd_lv] ;#light vertical - set vll $vl - set vlr $vl - set tlc [punk::char::charshort boxd_ladr] ;#light arc down and right \U256D - set trc [punk::char::charshort boxd_ladl] ;#light arc down and left \U256E - set blc [punk::char::charshort boxd_laur] ;#light arc up and right \U2570 - set brc [punk::char::charshort boxd_laul] ;#light arc up and left \U256F - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - #set targetdown,targetleft,targetright,targetup vars - #default empty targets to current box type 'arc' - foreach dir {down left right up} { - set target [tcl::dict::get $join_targets $dir] - switch -- $target { - "" - arc { - set target$dir self - } - default { - set target$dir other - } - } - } - - switch -- $do_joins { - down { - #1 - switch -- $targetdown { - self { - set blc \u251c ;# *light (ltj) - #set blc \u29FD ;# misc math right-pointing curved angle bracket (ltj) - positioned too far left - #set blc \u227b ;# math succeeds char. joins on right ok - gaps top and bottom - almost passable - #set blc \u22b1 ;#math succeeds under relation - looks 'ornate', sits too low to join horizontal - - #set brc \u2524 ;# *light(rtj) - #set brc \u29FC ;# misc math left-pointing curved angle bracket (rtj) - } - } - } - left { - #2 - switch -- $targetleft { - self { - set tlc \u252c ;# *light(ttj) - need a low positioned curved y shape - nothing apparent - #set blc \u2144 ;# (btj) - upside down y - positioning too low for arc - set blc \u2534 ;# *light (btj) - } - } - } - right { - #3 - switch -- $targetright { - self { - set trc \u252c ;# *light (ttj) - #set brc \u2144 ;# (btj) - set brc \u2534 ;# *light (btj) - } - } - } - up { - #4 - switch -- $targetup { - self { - set tlc \u251c ;# *light (ltj) - set trc \u2524 ;# *light(rtj) - } - } - } - down_left { - #5 - switch -- $targetdown-$targetleft { - self-self { - #set blc \u27e1 ;# white concave-sided diamond - positioned too far right - #set blc \u27e3 ;# concave sided diamond with rightwards tick - positioned too low, too right - big gaps - set brc \u2524 ;# *light (rtj) - set tlc \u252c ;# *light (ttj) - } - self-other { - #set blc \u2560 ;# (ltj) - #set brc \u2563 ;# (rtj) - #leave tlc as ordinary double corner - } - other-self { - #set blc \u2569 ;# (btj) - #leave brc as ordinary double corner - #set tlc \u2566 ;# (ttj) - } - } - } - } - } - 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 - set vlr \u2595 ;# right one eighth block - set tlc \u2581 ;# lower one eighth block - set trc \u2581 ;# lower one eighth block - set blc \u2594 ;# upper one eighth block - set brc \u2594 ;# upper one eight block - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - } - 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 vlr \u2595 ;# right one eighth block - set vll \u258f ;# left one eighth block - - #some terminals (on windows as at 2024) miscount width of these single-width blocks internally - #resulting in extra spacing that is sometimes well removed from the character itself (e.g at next ansi reset) - #This was fixed in windows-terminal based systems (2021) but persists in others. - #https://github.com/microsoft/terminal/issues/11694 - set tlc \U1fb7d ;#legacy block - set trc \U1fb7e ;#legacy block - set blc \U1fb7c ;#legacy block - set brc \U1fb7f ;#legacy block - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - } - block2hack { - #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 vlr \u2595 ;# right one eighth block - set vll \u258f ;# left one eighth block - - #see comments in block2 regarding the problems in some terminals that this *may* hack around to some extent. - #the caller probably only needs block2hack if block2 doesn't work - - #1) - #review - this hack looks sort of promising - but overtype::renderline needs fixing ? - #set tlc \U1fb7d\b ;#legacy block - #set trc \U1fb7e\b ;#legacy block - #set blc \U1fb7c\b ;#legacy block - #set brc \U1fb7f\b ;#legacy block - - #2) - works on cmd.exe and some others - # a 'privacy message' is 'probably' also not supported on the old terminal but is on newer ones - #known exception - conemu on windows - displays junk for various ansi codes - (and slow terminal anyway) - #this hack has a reasonable chance of working - #except that the punk overtype library does recognise PMs - #A single backspace however is an unlikely and generally unuseful PM - so there is a corresponding hack in the renderline system to pass this PM through! - #ugly - in that we don't know the application specifics of what the PM data contains and where it's going. - set tlc \U1fb7d\x1b^\b\x1b\\ ;#legacy block - set trc \U1fb7e\x1b^\b\x1b\\ ;#legacy block - set blc \U1fb7c\x1b^\b\x1b\\ ;#legacy block - set brc \U1fb7f\x1b^\b\x1b\\ ;#legacy block - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - } - block { - set hlt \u2580 ;#upper half - set hlb \u2584 ;#lower half - set vll \u258c ;#left half - set vlr \u2590 ;#right half - - set tlc \u259b ;#upper left corner half - set trc \u259c - set blc \u2599 - set brc \u259f - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - } - default { - 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" - } - #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'" - } - } - } - #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]] - } - } - #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} { - set result [tcl::dict::create\ - tlc $tlc hlt $hlt trc $trc\ - vll $vll vlr $vlr\ - blc $blc hlb $hlb brc $brc\ - ] - tcl::dict::set framedef_cache $cache_key $result - return $result - } else { - set result [tcl::dict::create\ - tlc $tlc hlt $hlt trc $trc\ - vll $vll vlr $vlr\ - blc $blc hlb $hlb brc $brc\ - hltj $hltj\ - hlbj $hlbj\ - vllj $vllj\ - vlrj $vlrj\ - ] - tcl::dict::set framedef_cache $cache_key $result - return $result - } - } - - variable frame_cache - set frame_cache [tcl::dict::create] - 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 - 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 - } - 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] - append out \nCLEARED - } - return $out - } - - - #options before content argument - which is allowed to be absent - #frame performance (noticeable with complex tables even of modest size) is improved somewhat by frame_cache - but is still (2024) a fairly expensive operation. - # - #consider if we can use -sticky nsew instead of -blockalign (as per Tk grid -sticky option) - # This would require some sort of expand equivalent e.g for -sticky ew or -sticky ns - for which we have to decide a meaning for text.. e.g ansi padding? - #We are framing 'rendered' text - so we don't have access to for example an inner frame or table to tell it to expand - #we could refactor as an object and provide a -return object option, then use stored -sticky data to influence how another object renders into it - # - but we would need to maintain support for the rendered-string based operations too. - proc frame {args} { - variable frametypes - variable use_md5 - - #counterintuitively - in-proc dict create each time is generally slightly faster than linked namespace var - set opts [tcl::dict::create\ - -etabs 0\ - -type light\ - -boxlimits [list hl vl tlc blc trc brc]\ - -boxmap {}\ - -joins [list]\ - -title ""\ - -subtitle ""\ - -width ""\ - -height ""\ - -ansiborder ""\ - -ansibase ""\ - -blockalign "centre"\ - -textalign "left"\ - -ellipsis 1\ - -usecache 1\ - -buildcache 1\ - -pad 1\ - -crm_mode 0\ - ] - #-pad 1 is default so that simple 'textblock::frame "[a+ Red]a \nbbb[a]" extends the bg colour on the short ragged lines (and empty lines) - # for ansi art - -pad 0 is likely to be preferable - - set expect_optval 0 - set argposn 0 - set pmax [expr {[llength $args]-1}] - set has_contents 0 ;#differentiate between empty string and no content supplied - set contents "" - set arglist [list] - foreach a $args { - if {!$expect_optval} { - if {$argposn < $pmax} { - if {[tcl::string::match -* $a]} { - set expect_optval 1 - lappend arglist $a - } else { - error "textblock::frame expects -option pairs" - } - } else { - set has_contents 1 - set contents $a - } - } else { - lappend arglist $a - set expect_optval 0 - } - incr argposn - } - - #set contents [lindex $args end] - #set arglist [lrange $args 0 end-1] - if {[llength $arglist] % 2 != 0} { - error "Usage frame ?-type unicode|altg|ascii|? ?-title ? ?-subtitle ? ?-width ? ?-ansiborder ? ?-boxlimits hl|hlt|hlb|vl|vll|vlr|tlc|blc|brc? ?-joins left|right|up|down? " - } - #todo args -justify left|centre|right (center) - - #todo -blockalignbias -textalignbias? - #use -buildcache 1 with -usecache 0 for debugging cache issues so we can inspect using textblock::frame_cache - foreach {k v} $arglist { - switch -- $k { - -etabs - -type - -boxlimits - -boxmap - -joins - - -title - -subtitle - -width - -height - - -ansiborder - -ansibase - - -blockalign - -textalign - -ellipsis - - -crm_mode - - -usecache - -buildcache - -pad { - tcl::dict::set opts $k $v - } - default { - error "frame option '$k' not understood. Valid options are [tcl::dict::keys $opts]" - } - } - } - # -- --- --- --- --- --- - set opt_etabs [tcl::dict::get $opts -etabs] - set opt_type [tcl::dict::get $opts -type] - set opt_boxlimits [tcl::dict::get $opts -boxlimits] - set opt_joins [tcl::dict::get $opts -joins] - set opt_boxmap [tcl::dict::get $opts -boxmap] - set opt_usecache [tcl::dict::get $opts -usecache] - set opt_buildcache [tcl::dict::get $opts -buildcache] - set opt_pad [tcl::dict::get $opts -pad] - set opt_crm_mode [tcl::dict::get $opts -crm_mode] - set usecache $opt_usecache ;#may need to override - set buildcache $opt_buildcache - set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] - - set known_frametypes $frametypes ;# light, heavey etc as defined in the ::textblock::frametypes variable - set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] - - lassign [textblock::frametype $opt_type] _cat category _type ftype - if {$category eq "custom"} { - set custom_frame $ftype - set frameset "custom" - set framedef $custom_frame - } else { - #category = predefined - set frameset $ftype ;# light,heavy etc - set framedef $ftype - } - - set is_boxlimits_ok 1 - set exact_boxlimits [list] - foreach v $opt_boxlimits { - switch -- $v { - hl { - lappend exact_boxlimits hlt hlb - } - vl { - lappend exact_boxlimits vll vlr - } - hlt - hlb - vll - vlr - tlc - trc - blc - brc { - lappend exact_boxlimits $v - } - default { - #k not in custom_keys - set is_boxlimits_ok 0 - break - } - } - } - if {!$is_boxlimits_ok} { - error "frame option -boxlimits '$opt_boxlimits' must contain only values from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" - } - set exact_boxlimits [lsort -unique $exact_boxlimits] - - set is_joins_ok 1 - foreach v $opt_joins { - lassign [split $v -] direction target - switch -- $direction { - left - right - up - down {} - default { - set is_joins_ok 0 - break - } - } - switch -- $target { - "" - light - heavy - ascii - altg - arc - double - custom - block - block1 - block2 {} - default { - set is_joins_ok 0 - break - } - } - } - if {!$is_joins_ok} { - error "frame option -joins '$opt_joins' must contain only values from the set: left,right,up,down with targets heavy,light,ascii,altg,arc,double,block,block1,custom e.g down-light" - } - set is_boxmap_ok 1 - #safe jumptable test - #dict for {boxelement subst} $opt_boxmap {} - tcl::dict::for {boxelement subst} $opt_boxmap { - switch -- $boxelement { - hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} - default { - set is_boxmap_ok 0 - break - } - } - } - if {!$is_boxmap_ok} { - error "frame option -boxmap '$opt_boxmap' must contain only keys from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" - } - - #sorted order down left right up - #1 x choose 4 - #4 x choose 3 - #6 x choose 2 - #4 x choose 1 - #15 combos - - set join_directions [list] - #targets - light,heavy (double?) - seem to be some required glyphs missing from unicode - #e.g down-light, up-heavy - set join_targets [tcl::dict::create left "" down "" right "" up ""] - foreach jt $opt_joins { - lassign [split $jt -] direction target - if {$target ne ""} { - tcl::dict::set join_targets $direction $target - } - lappend join_directions $direction - } - set join_directions [lsort -unique $join_directions] - set do_joins [::join $join_directions _] - - - # -- --- --- --- --- --- - set opt_title [tcl::dict::get $opts -title] - set opt_subtitle [tcl::dict::get $opts -subtitle] - set opt_width [tcl::dict::get $opts -width] - set opt_height [tcl::dict::get $opts -height] - # -- --- --- --- --- --- - set opt_blockalign [tcl::dict::get $opts -blockalign] - switch -- $opt_blockalign { - left - right - centre - center {} - default { - error "frame option -blockalign must be left|right|centre|center - received: $opt_blockalign" - } - } - #these are all valid commands for overtype:: - # -- --- --- --- --- --- - set opt_textalign [tcl::dict::get $opts -textalign] - switch -- $opt_textalign { - left - right - centre - center {} - default { - error "frame option -textalign must be left|right|centre|center - received: $opt_textalign" - } - } - # -- --- --- --- --- --- - - set opt_ansiborder [tcl::dict::get $opts -ansiborder] - set opt_ansibase [tcl::dict::get $opts -ansibase] ;#experimental - set opt_ellipsis [tcl::dict::get $opts -ellipsis] - # -- --- --- --- --- --- - - if {$has_contents} { - if {[tcl::string::last \t $contents] >= 0} { - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - if {$opt_etabs} { - set contents [textutil::tabify::untabify2 $contents $tw] - } - } - set contents [tcl::string::map [list \r\n \n] $contents] - if {$opt_crm_mode} { - if {$opt_height eq ""} { - set h [textblock::height $contents] - } else { - set h [expr {$opt_height -2}] - } - if {$opt_width eq ""} { - set w [textblock::width $contents] - } else { - set w [expr {$opt_width -2}] - } - set contents [overtype::renderspace -crm_mode 1 -wrap 1 -width $w -height $h "" $contents] - } - set actual_contentwidth [textblock::width $contents] ;#length of longest line in contents (contents can be ragged) - set actual_contentheight [textblock::height $contents] - } else { - set actual_contentwidth 0 - set actual_contentheight 0 - } - - if {$opt_title ne ""} { - set titlewidth [punk::ansi::printing_length $opt_title] - set content_or_title_width [expr {max($actual_contentwidth,$titlewidth)}] - } else { - set titlewith 0 - set content_or_title_width $actual_contentwidth - } - - if {$opt_width eq ""} { - set frame_inner_width $content_or_title_width - } else { - set frame_inner_width [expr {max(0,$opt_width - 2)}] ;#default - } - - if {$opt_height eq ""} { - set frame_inner_height $actual_contentheight - } else { - set frame_inner_height [expr {max(0,$opt_height -2)}] ;#default - } - if {$frame_inner_height == 0 && $frame_inner_width == 0} { - set has_contents 0 - } - #todo - render it with vertical overflow so we can process ansi moves? - #set linecount [textblock::height $contents] - set linecount $frame_inner_height - - # -- --- --- --- --- --- --- --- --- - variable frame_cache - #review - custom frame affects frame_inner_width - exclude from caching? - #set cache_key [concat $arglist $frame_inner_width $frame_inner_height] - set hashables [concat $arglist $frame_inner_width $frame_inner_height] - - if {$use_md5} { - #package require md5 ;#already required at package load - if {[package vsatisfies [package present md5] 2- ] } { - set hash [md5::md5 -hex [encoding convertto utf-8 $hashables]] ;#need fast and unique to content - not cryptographic - review - } else { - set hash [md5::md5 [encoding convertto utf-8 $hashables]] - } - } else { - set hash $hashables - } - - set cache_key "$hash-$frame_inner_width-$frame_inner_height-actualcontentwidth:$actual_contentwidth" - #should be in a unicode private range different to that used in table construction - #e.g BMP PUA U+E000 -> U+F8FF - although this is commonly used for example by nerdfonts - #also supplementary private use blocks - #however these display double wide on for example cmd terminal despite having wcswidth 1 (makes layout debugging difficult) - #U+F0000 -> U+FFFD - #U+100000 -> U+10FFFD - #FSUB options: \uf0ff \uF1FF \uf2ff (no nerdfont glyphs - should look like standard replacement char) \uF2DD (circular thingy) - #should be something someone is unlikely to use as part of a custom frame character. - #ideally a glyph that doesn't auto-expand into whitespace and is countable when in a string (narrower is better) - #As nerdfont glyphs tend to be mostly equal height & width - circular glyphs tend to be more distinguishable in a string - #terminal settings may need to be adjusted to stop auto glyph resizing - a rather annoying misfeature that some people seem to think they like. - #e.g in wezterm config: allow_square_glyphs_to_overflow_width = "Never" - #review - we could consider wasting a few cycles to check for a conflict and use a different FSUB - set FSUB \uF2DD - - - #this occurs commonly in table building with colspans - review - if {($actual_contentwidth > $frame_inner_width) || ($actual_contentheight != $frame_inner_height)} { - set usecache 0 - #set buildcache 0 ;#comment out for debug/analysis so we can see - #puts "--->> frame_inner_width:$frame_inner_width actual_contentwidth:$actual_contentwidth contents: '$contents'" - set cache_key [a+ Web-red web-white]$cache_key[a] - } - if {$buildcache && ($actual_contentwidth < $frame_inner_width)} { - #colourise cache_key to warn - if {$actual_contentwidth == 0} { - #we can still substitute with right length - set cache_key [a+ Web-steelblue web-black]$cache_key[a] - } else { - #actual_contentwidth is narrower than frame - check template's patternwidth - if {[tcl::dict::exists $frame_cache $cache_key]} { - set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] - } else { - set cache_patternwidth $actual_contentwidth - } - if {$actual_contentwidth < $cache_patternwidth} { - set usecache 0 - set cache_key [a+ Web-orange web-black]$cache_key[a] - } elseif {$actual_contentwidth == $cache_patternwidth} { - #set usecache 1 - } else { - #actual_contentwidth > pattern - set usecache 0 - set cache_key [a+ Web-red web-black]$cache_key[a] - } - } - } - - #JMN debug - #set usecache 0 - - set is_cached 0 - if {$usecache && [tcl::dict::exists $frame_cache $cache_key]} { - set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] - set template [tcl::dict::get $frame_cache $cache_key frame] - set used [tcl::dict::get $frame_cache $cache_key used] - tcl::dict::set frame_cache $cache_key used [expr {$used+1}] ;#update existing record - set is_cached 1 - - } - - # -- --- --- --- --- --- --- --- --- - if {!$is_cached} { - set rst [a] - #set column [tcl::string::repeat " " $frame_inner_width] ;#default - may need to override for custom frame - set underlayline [tcl::string::repeat " " $frame_inner_width] - set underlay [::join [lrepeat $linecount $underlayline] \n] - - - set vll_width 1 ;#default for all except custom (printing width) - set vlr_width 1 - - set framedef [textblock::framedef -joins $opt_joins $framedef] - tcl::dict::with framedef {} ;#extract vll,hlt,tlc etc vars - - #puts "---> $opt_boxmap" - #review - we handle double-wide in custom frames - what about for boxmaps? - tcl::dict::for {boxelement sub} $opt_boxmap { - if {$boxelement eq "vl"} { - set vll $sub - set vlr $sub - set hl $sub - } elseif {$boxelement eq "hl"} { - set hlt $sub - set hlb $sub - set hl $sub - } else { - set $boxelement $sub - } - } - - switch -- $frameset { - custom { - #REVIEW - textblock::table assumes that at least the vl elements are 1-wide - #generally supporting wider or taller custom frame elements would make for some interesting graphical possibilities though - #if no ansi, these widths are reasonable to maintain in grapheme_width_cached indefinitely - set vll_width [punk::ansi::printing_length $vll] - set hlb_width [punk::ansi::printing_length $hlb] - set hlt_width [punk::ansi::printing_length $hlt] - - set vlr_width [punk::ansi::printing_length $vlr] - - set tlc_width [punk::ansi::printing_length $tlc] - set trc_width [punk::ansi::printing_length $trc] - set blc_width [punk::ansi::printing_length $blc] - set brc_width [punk::ansi::printing_length $brc] - - - set framewidth [expr {$frame_inner_width + 2}] ;#reverse default assumption - if {$opt_width eq ""} { - #width wasn't specified - so user is expecting frame to adapt to title/contents - #content shouldn't truncate because of extra wide frame - #review - punk::console::get_size ? wrapping? quite hard to support with colspans - set frame_inner_width $content_or_title_width - set tbarwidth [expr {$content_or_title_width + 2 - $tlc_width - $trc_width - 2 + $vll_width + $vlr_width}] ;#+/2's for difference between border element widths and standard element single-width - set bbarwidth [expr {$content_or_title_width + 2 - $blc_width - $brc_width - 2 + $vll_width + $vlr_width}] - } else { - set frame_inner_width [expr $opt_width - $vll_width - $vlr_width] ;#content may be truncated - set tbarwidth [expr {$opt_width - $tlc_width - $trc_width}] - set bbarwidth [expr {$opt_width - $blc_width - $brc_width}] - } - #set column [tcl::string::repeat " " $frame_inner_width] - set underlayline [tcl::string::repeat " " $frame_inner_width] - set underlay [::join [lrepeat $linecount $underlayline] \n] - #cache? - - if {$hlt_width == 1} { - set tbar [tcl::string::repeat $hlt $tbarwidth] - } else { - #possibly mixed width chars that make up hlt - tcl::string::range won't get width right - set blank [tcl::string::repeat " " $tbarwidth] - if {$hlt_width > 0} { - set count [expr {($tbarwidth / $hlt_width) + 1}] - } else { - set count 0 - } - set tbar [tcl::string::repeat $hlt $count] - #set tbar [tcl::string::range $tbar 0 $tbarwidth-1] - set tbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $tbar];#spaces for exposed halves of 2w chars instead of default replacement character - } - if {$hlb_width == 1} { - set bbar [tcl::string::repeat $hlb $bbarwidth] - } else { - set blank [tcl::string::repeat " " $bbarwidth] - if {$hlb_width > 0} { - set count [expr {($bbarwidth / $hlb_width) + 1}] - } else { - set count 0 - } - set bbar [tcl::string::repeat $hlb $count] - #set bbar [tcl::string::range $bbar 0 $bbarwidth-1] - set bbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $bbar] - } - } - altg { - set tbar [tcl::string::repeat $hlt $frame_inner_width] - set tbar [cd::groptim $tbar] - set bbar [tcl::string::repeat $hlb $frame_inner_width] - set bbar [cd::groptim $bbar] - } - default { - set tbar [tcl::string::repeat $hlt $frame_inner_width] - set bbar [tcl::string::repeat $hlb $frame_inner_width] - - } - } - - set leftborder 0 - set rightborder 0 - set topborder 0 - set bottomborder 0 - # hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} - #puts "----->$exact_boxlimits" - foreach lim $exact_boxlimits { - switch -- $lim { - hlt { - set topborder 1 - } - hlb { - set bottomborder 1 - } - vll { - set leftborder 1 - } - vlr { - set rightborder 1 - } - tlc { - set topborder 1 - set leftborder 1 - } - trc { - set topborder 1 - set rightborder 1 - } - blc { - set bottomborder 1 - set leftborder 1 - } - brc { - set bottomborder 1 - set rightborder 1 - } - } - } - if {$opt_width ne "" && $opt_width < 2} { - set rightborder 0 - } - #keep lhs/rhs separate? can we do vertical text on sidebars? - set lhs [tcl::string::repeat $vll\n $linecount] - set lhs [tcl::string::range $lhs 0 end-1] - set rhs [tcl::string::repeat $vlr\n $linecount] - set rhs [tcl::string::range $rhs 0 end-1] - - - if {$opt_ansiborder ne ""} { - set tbar $opt_ansiborder$tbar$rst - set bbar $opt_ansiborder$bbar$rst - set tlc $opt_ansiborder$tlc$rst - set trc $opt_ansiborder$trc$rst - set blc $opt_ansiborder$blc$rst - set brc $opt_ansiborder$brc$rst - - set lhs $opt_ansiborder$lhs$rst ;#wrap the whole block and let textblock::join figure it out - set rhs $opt_ansiborder$rhs$rst - } - - #boxlimits used for partial borders in table generation - set all_exact_boxlimits [list vll vlr hlt hlb tlc blc trc brc] - set unspecified_limits [struct::set difference $all_exact_boxlimits $exact_boxlimits] - foreach lim $unspecified_limits { - switch -- $lim { - vll { - set blank_vll [tcl::string::repeat " " $vll_width] - set lhs [tcl::string::repeat $blank_vll\n $linecount] - set lhs [tcl::string::range $lhs 0 end-1] - } - vlr { - set blank_vlr [tcl::string::repeat " " $vlr_width] - set rhs [tcl::string::repeat $blank_vlr\n $linecount] - set rhs [tcl::string::range $rhs 0 end-1] - } - hlt { - set bar_width [punk::ansi::printing_length $tbar] - set tbar [tcl::string::repeat " " $bar_width] - } - tlc { - set tlc_width [punk::ansi::printing_length $tlc] - set tlc [tcl::string::repeat " " $tlc_width] - } - trc { - set trc_width [punk::ansi::printing_length $trc] - set trc [tcl::string::repeat " " $trc_width] - } - hlb { - set bar_width [punk::ansi::printing_length $bbar] - set bbar [tcl::string::repeat " " $bar_width] - } - blc { - set blc_width [punk::ansi::printing_length $blc] - set blc [tcl::string::repeat " " $blc_width] - } - brc { - set brc_width [punk::ansi::printing_length $brc] - set brc [tcl::string::repeat " " $brc_width] - } - } - } - - if {$opt_title ne ""} { - set topbar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $tbar $opt_title] ;#overtype supports gx0 on/off - } else { - set topbar $tbar - } - if {$opt_subtitle ne ""} { - set bottombar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $bbar $opt_subtitle] ;#overtype supports gx0 on/off - } else { - set bottombar $bbar - } - if {$opt_ansibase eq ""} { - set rstbase [a] - } else { - set rstbase [a]$opt_ansibase - } - - if {$opt_title ne ""} { - #title overrides -boxlimits for topborder - set topborder 1 - } - set fs "" - set fscached "" - set cache_patternwidth 0 - #todo - output nothing except maybe newlines depending on if opt_height 0 and/or opt_width 0? - if {$topborder} { - if {$leftborder && $rightborder} { - append fs $tlc$topbar$trc - } else { - if {$leftborder} { - append fs $tlc$topbar - } elseif {$rightborder} { - append fs $topbar$trc - } else { - append fs $topbar - } - } - } - append fscached $fs - if {$has_contents || $opt_height > 2} { - #if {$topborder && $fs ne "xx"} { - # append fs \n - #} - if {$topborder} { - append fs \n - append fscached \n - } - switch -- $opt_textalign { - right {set pad "left"} - left {set pad "right"} - default {set pad $opt_textalign} - } - #set textaligned_contents [textblock::pad $contents -width $actual_contentwidth -which $pad -within_ansi 1] - #set inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$textaligned_contents] - - set cache_contentline [tcl::string::repeat $FSUB $actual_contentwidth] - set cache_patternwidth $actual_contentwidth - set cache_contentpattern [::join [lrepeat $linecount $cache_contentline] \n] - set cache_inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$cache_contentpattern] - #after overtype::block - our actual patternwidth may be less - set cache_patternwidth [tcl::string::length [lindex [regexp -inline "\[^$FSUB]*(\[$FSUB]*).*" $cache_inner] 1]] - - if {$leftborder && $rightborder} { - #set bodyparts [list $lhs $inner $rhs] - set cache_bodyparts [list $lhs $cache_inner $rhs] - } else { - if {$leftborder} { - #set bodyparts [list $lhs $inner] - set cache_bodyparts [list $lhs $cache_inner] - } elseif {$rightborder} { - #set bodyparts [list $inner $rhs] - set cache_bodyparts [list $cache_inner $rhs] - } else { - #set bodyparts [list $inner] - set cache_bodyparts [list $cache_inner] - } - } - #set body [textblock::join -- {*}$bodyparts] - set cache_body [textblock::join -- {*}$cache_bodyparts] - append fscached $cache_body - #append fs $body - } - - if {$opt_height eq "" || $opt_height > 1} { - if {$opt_subtitle ne ""} { - #subtitle overrides boxlimits for bottomborder - set bottomborder 1 - } - if {$bottomborder} { - if {($topborder & $fs ne "xx" ) || ($has_contents || $opt_height > 2)} { - #append fs \n - append fscached \n - } - if {$leftborder && $rightborder} { - #append fs $blc$bottombar$brc - append fscached $blc$bottombar$brc - } else { - if {$leftborder} { - #append fs $blc$bottombar - append fscached $blc$bottombar - } elseif {$rightborder} { - #append fs $bottombar$brc - append fscached $bottombar$brc - } else { - #append fs $bottombar - append fscached $bottombar - } - } - } - } - set template $fscached - ;#end !$is_cached - } - - #use the same mechanism to build the final frame - whether from cache or template - if {$actual_contentwidth == 0} { - set fs [tcl::string::map [list $FSUB " "] $template] - } else { - set resultlines [list] - set overwritable [tcl::string::repeat $FSUB $cache_patternwidth] - set contentindex 0 - switch -- $opt_textalign { - left {set pad right} - right {set pad left} - default {set pad $opt_textalign} - } - - #review - if {[tcl::string::is integer -strict $opt_height] && $actual_contentheight < ($opt_height -2)} { - set diff [expr {($opt_height -2) - $actual_contentheight}] - append contents [::join [lrepeat $diff \n] ""] - } - - if {$opt_pad} { - set paddedcontents [textblock::pad $contents -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth) - set paddedwidth [textblock::widthtopline $paddedcontents] - #review - horizontal truncation - if {$paddedwidth > $cache_patternwidth} { - set paddedcontents [overtype::renderspace -width $cache_patternwidth "" $paddedcontents] - } - #important to supply end of opts -- to textblock::join - particularly here with arbitrary data - set contentblock [textblock::join -- $paddedcontents] ;#make sure each line has ansi replays - } else { - set cwidth [textblock::width $contents] - if {$cwidth > $cache_patternwidth} { - set contents [overtype::renderspace -width $cache_patternwidth "" $contents] - } - set contentblock [textblock::join -- $contents] - } - - set tlines [split $template \n] - - #we will need to strip off the leading reset on each line when stitching together with template lines so that ansibase can come into play too. - #after textblock::join the reset will be a separate code ie should be exactly ESC[0m - set R [a] - set rlen [tcl::string::length $R] - set clines [split $contentblock \n] - - foreach tline $tlines { - if {[tcl::string::first $FSUB $tline] >= 0} { - set content_line [lindex $clines $contentindex] - if {[tcl::string::first $R $content_line] == 0} { - set content_line [tcl::string::range $content_line $rlen end] - } - #make sure to replay opt_ansibase to the right of the replacement - lappend resultlines [tcl::string::map [list $overwritable $content_line$opt_ansibase] $tline] - incr contentindex - } else { - lappend resultlines $tline - } - } - set fs [::join $resultlines \n] - } - - - if {$is_cached} { - return $fs - } else { - if {$buildcache} { - tcl::dict::set frame_cache $cache_key [list frame $template used 0 patternwidth $cache_patternwidth] - } - return $fs - } - } - 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 opt_max_cross_size [tcl::dict::get $opts -max_cross_size] - - #set fit_size [punk::lib::greatestOddFactor $size] - set fit_size $size - if {$opt_max_cross_size == 0} { - set max_cross_size $fit_size - } else { - #todo - only allow divisors - #set testsize [expr {min($fit_size,$opt_max_cross_size)}] - - set factors [punk::lib::factors $size] - #pick odd size in list that is smaller or equal to test_size - set max_cross_size [lindex $factors end] - set last_ok [lindex $factors 0] - for {set i 0} {$i < [llength $factors]} {incr i} { - set s [lindex $factors $i] - if {$s > $opt_max_cross_size} { - break - } - set last_ok $s - } - set max_cross_size $last_ok - } - set crosscount [expr {$size / $max_cross_size}] - - package require punk::char - set x [punk::char::charshort boxd_ldc] - set bs [punk::char::charshort boxd_ldgullr] - set fs [punk::char::charshort boxd_ldgurll] - - set onecross "" - set crossrows [list] - set armsize [expr {int(floor($max_cross_size /2))}] - set row [lrepeat $max_cross_size " "] - #toparm - for {set i 0} {$i < $armsize} {incr i} { - set r $row - lset r $i $bs - lset r end-$i $fs - #append onecross [::join $r ""] \n - lappend crossrows [::join $r ""] - } - - if {$max_cross_size % 2 != 0} { - #only put centre cross in for odd sized crosses - set r $row - lset r $armsize $x - #append onecross [::join $r ""] \n - lappend crossrows [::join $r ""] - } - - for {set i [expr {$armsize -1}]} {$i >= 0} {incr i -1} { - set r $row - lset r $i $fs - lset r end-$i $bs - #append onecross [::join $r ""] \n - lappend crossrows [::join $r ""] - } - #set onecross [tcl::string::trimright $onecross \n] - set onecross [::join $crossrows \n] - - #fastest to do row first then columns - because textblock::join must do line by line - - if {$crosscount > 1} { - set row [textblock::join -- {*}[lrepeat $crosscount $onecross]] - set rows [lrepeat $crosscount $row] - set out [::join $rows \n] - } else { - set out $onecross - } - - return $out - } - - #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] - puts $result - #return [list $b1 $b2 $result] - return [ansistring VIEW $result] - } - tcl::namespace::import ::punk::ansi::ansistrip -} - - -tcl::namespace::eval ::textblock::piper { - tcl::namespace::export * - proc join {rhs pipelinedata} { - tailcall ::textblock::join -- $pipelinedata $rhs - } -} -interp alias {} piper_blockjoin {} ::textblock::piper::join - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide textblock [tcl::namespace::eval textblock { - variable version - set version 0.1.1 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.2.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.2.tm deleted file mode 100644 index a3d5b967..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.2.tm +++ /dev/null @@ -1,8520 +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) 2023 -# -# @@ Meta Begin -# Application textblock 0.1.2 -# Meta platform tcl -# Meta license -# @@ Meta End - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_textblock 0 0.1.2] -#[copyright "2024"] -#[titledesc {punk textblock functions}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk textblock}] [comment {-- Description at end of page heading --}] -#[require textblock] -#[keywords module ansi text layout colour table frame console terminal] -#[description] -#[para] Ansi-aware terminal textblock manipulation - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of textblock -#[subsection Concepts] -#[para] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by textblock -#[list_begin itemized] - -#*** !doctools -#[item] [package {Tcl 8.6-}] -#[item] [package {punk::args}] -#[item] [package {punk::char}] -#[item] [package {punk::ansi}] -#[item] [package {punk::lib}] -#[item] [package {overtype}] -#[item] [package {term::ansi::code::macros}] -#[item] [package {textutil}] - -## Requirements -package require Tcl 8.6- -package require punk::args -package require punk::char -package require punk::ansi -package require punk::lib -catch {package require patternpunk} -package require overtype - -#safebase interps as at 2024-08 can't access deeper paths - even though they are below the supposed safe list. -if {[catch { - package require term::ansi::code::macros ;#required for frame if old ansi g0 used - review - make package optional? -} errM]} { - #catch this too in case stderr not available - catch { - puts stderr "textblock package failed to load term::ansi::code::macros with error: $errM" - } -} -package require textutil - - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -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 - - #NOTE sha1, although computationally more intensive, tends to be faster than md5 on modern cpus - #(more likely to be optimised for modern cpu features?) - #(This speed improvement may not apply for short strings) - - variable use_hash ;#framecache - set use_hash none ;#slightly faster but uglier layout for viewing frame_cache display - #if {![catch {package require sha1}]} { - # set use_hash sha1 - #} elseif {![catch {package require md5}]} { - # set use_hash md5 - #} else { - # set use_hash none - #} - - proc use_hash {args} { - set choices [list none] - set unavailable [list] - set pkgs [package names] - if {"md5" in $pkgs} { - lappend choices md5 - } else { - lappend unavailable md5 - } - if {"sha1" in $pkgs} { - lappend choices sha1 - } else { - lappend unavailable sha1 - } - set choicemsg "" - if {[llength $unavailable]} { - set choicemsg " (unavailable packages: $unavailable)" - } - set argd [punk::args::get_dict [tstr -return string { - @id -id ::textblock::use_hash - @cmd -name "textblock::use_hash" -help\ - "Hashing algorithm to use for framecache lookup. - 'none' may be slightly faster but less compact - when viewing textblock::framecache" - @values -min 0 -max 1 - hash_algorithm -choices {${$choices}} -optional 1 -help\ - "algorithm choice ${$choicemsg}" - }] $args] - variable use_hash - if {![dict exists $argd received hash_algorithm]} { - return $use_hash - } - set use_hash [dict get $argd values hash_algorithm] - } - tcl::namespace::eval class { - variable opts_table_defaults - set opts_table_defaults [tcl::dict::create\ - -title ""\ - -titlealign "left"\ - -titletransparent 0\ - -frametype "light"\ - -frametype_header ""\ - -ansibase_header ""\ - -ansibase_body ""\ - -ansibase_footer ""\ - -ansiborder_header ""\ - -ansiborder_body ""\ - -ansiborder_footer ""\ - -ansireset "\uFFeF"\ - -framelimits_header "vll vlr hlb hlt tlc trc blc brc"\ - -frametype_body ""\ - -framelimits_body "vll vlr hlb hlt tlc trc blc brc"\ - -framemap_body [list\ - topleft {} topinner {} topright {} topsolo {}\ - middleleft {} middleinner {} middleright {} middlesolo {}\ - bottomleft {} bottominner {} bottomright {} bottomsolo {}\ - onlyleft {} onlyinner {} onlyright {} onlysolo {}\ - ]\ - -framemap_header [list\ - topleft {} topinner {} topright {} topsolo {}\ - middleleft {} middleinner {} middleright {} middlesolo {}\ - bottomleft {} bottominner {} bottomright {} bottomsolo {}\ - onlyleft {} onlyinner {} onlyright {} onlysolo {}\ - ]\ - -show_edge 1\ - -show_seps 1\ - -show_hseps ""\ - -show_vseps ""\ - -show_header ""\ - -show_footer ""\ - -minwidth ""\ - -maxwidth ""\ - ] - variable opts_column_defaults - set opts_column_defaults [tcl::dict::create\ - -headers [list]\ - -header_colspans [list]\ - -footers [list]\ - -defaultvalue ""\ - -ansibase ""\ - -ansireset "\uFFEF"\ - -minwidth ""\ - -maxwidth ""\ - -blockalign centre\ - -textalign left\ - ] - #initialise -ansireset with replacement char so we can keep in appropriate dict position for initial configure and then treat as read-only - - - - #for 'L' shaped table building pattern (tables bigger than 4x4 will be mostly 'L' patterns) - #ie only vll,blc,hlb used for cells except top row and right column - #top right cell uses all 'O' shape, other top cells use 'C' shape (hlt,tlc,vll,blc,hlb) - #right cells use 'U' shape (vll,blc,hlb,brc,vlr) - #e.g for 4x4 - # C C C O - # L L L U - # L L L U - #anti-clockwise elements - set C [list hlt tlc vll blc hlb] - set O [list trc hlt tlc vll blc hlb brc vlr] - set L [list vll blc hlb] - set U [list vll blc hlb brc vlr] - set tops [list trc hlt tlc] - set lefts [list tlc vll blc] - set bottoms [list blc hlb brc] - set rights [list trc brc vlr] - - variable table_edge_parts - set table_edge_parts [tcl::dict::create\ - topleft [struct::set intersect $C [concat $tops $lefts]]\ - topinner [struct::set intersect $C $tops]\ - topright [struct::set intersect $O [concat $tops $rights]]\ - topsolo [struct::set intersect $O [concat $tops $lefts $rights]]\ - middleleft [struct::set intersect $L $lefts]\ - middleinner [list]\ - middleright [struct::set intersect $U $rights]\ - middlesolo [struct::set intersect $U [concat $lefts $rights]]\ - bottomleft [struct::set intersect $L [concat $lefts $bottoms]]\ - bottominner [struct::set intersect $L $bottoms]\ - bottomright [struct::set intersect $U [concat $bottoms $rights]]\ - bottomsolo [struct::set intersect $U [concat $lefts $bottoms $rights]]\ - onlyleft [struct::set intersect $C [concat $tops $lefts $bottoms]]\ - onlyinner [struct::set intersect $C [concat $tops $bottoms]]\ - onlyright [struct::set intersect $O [concat $tops $bottoms $rights]]\ - onlysolo [struct::set intersect $O [concat $tops $lefts $bottoms $rights]]\ - ] - - #for header rows - we don't consider the bottom border as part of the edge - even if table body has no rows - #The usual-case of a single header line is the 'onlyleft,onlyinner,onlyright,onlysolo' set. - variable header_edge_parts - set header_edge_parts [tcl::dict::create\ - topleft [struct::set intersect $C [list {*}$tops {*}$lefts]]\ - topinner [struct::set intersect $C $tops]\ - topright [struct::set intersect $O [list {*}$tops {*}$rights]]\ - topsolo [struct::set intersect $O [list {*}$tops {*}$lefts {*}$rights]]\ - middleleft [struct::set intersect $L $lefts]\ - middleinner [list]\ - middleright [struct::set intersect $U $rights]\ - middlesolo [struct::set intersect $U [list {*}$lefts {*}$rights]]\ - bottomleft [struct::set intersect $L $lefts]\ - bottominner [list]\ - bottomright [struct::set intersect $U $rights]\ - bottomsolo [struct::set intersect $U [list {*}$lefts {*}$rights]]\ - onlyleft [struct::set intersect $C [list {*}$tops {*}$lefts]]\ - onlyinner [struct::set intersect $C $tops]\ - onlyright [struct::set intersect $O [list {*}$tops {*}$rights]]\ - onlysolo [struct::set intersect $O [list {*}$tops {*}$lefts {*}$rights]]\ - ] - variable table_hseps - set table_hseps [tcl::dict::create\ - topleft [list blc hlb]\ - topinner [list blc hlb]\ - topright [list blc hlb brc]\ - topsolo [list blc hlb brc]\ - middleleft [list blc hlb]\ - middleinner [list blc hlb]\ - middleright [list blc hlb brc]\ - middlesolo [list blc hlb brc]\ - bottomleft [list]\ - bottominner [list]\ - bottomright [list]\ - bottomsolo [list]\ - onlyleft [list]\ - onlyinner [list]\ - onlyright [list]\ - onlysolo [list]\ - ] - variable table_vseps - set table_vseps [tcl::dict::create\ - topleft [list]\ - topinner [list vll tlc blc]\ - topright [list vll tlc blc]\ - topsolo [list]\ - middleleft [list]\ - middleinner [list vll tlc blc]\ - middleright [list vll tlc blc]\ - middlesolo [list]\ - bottomleft [list]\ - bottominner [list vll tlc blc]\ - bottomright [list vll tlc blc]\ - bottomsolo [list]\ - onlyleft [list]\ - onlyinner [list vll tlc blc]\ - onlyright [list vll tlc blc]\ - onlysolo [list]\ - ] - - #ensembles seem to be not compiled in safe interp - #https://core.tcl-lang.org/tcl/tktview/1095bf7f75 - #as we want textblock to be usable in safe interps - use tcl::dict::for as a partial workaround - #This at least means the script argument, especially switch statements can get compiled. - #It does however affect all ensemble commands - so even 'dict get/set' etc won't be as efficient in a safe interp. - - #e.g $t configure -framemap_body [table_edge_map " "] - - # -- --- --- --- --- - #unused? - proc table_edge_map {char} { - variable table_edge_parts - set map [list] - tcl::dict::for {celltype parts} $table_edge_parts { - set tmap [list] - foreach p $parts { - tcl::dict::set tmap $p $char - } - tcl::dict::set map $celltype $tmap - } - return $map - } - proc table_sep_map {char} { - variable table_hseps - set map [list] - tcl::dict::for {celltype parts} $table_hseps { - set tmap [list] - foreach p $parts { - tcl::dict::set tmap $p $char - } - tcl::dict::set map $celltype $tmap - } - return $map - } - proc header_edge_map {char} { - variable header_edge_parts - set map [list] - tcl::dict::for {celltype parts} $header_edge_parts { - set tmap [list] - foreach p $parts { - tcl::dict::set tmap $p $char - } - tcl::dict::set map $celltype $tmap - } - return $map - } - # -- --- --- --- --- - - if {[tcl::info::commands [tcl::namespace::current]::table] eq ""} { - #*** !doctools - #[subsection {Namespace textblock::class}] - #[para] class definitions - #[list_begin itemized] [comment {- textblock::class groupings -}] - # [item] - # [para] [emph {handler_classes}] - # [list_begin enumerated] - - #this makes new table objects a little faster when multiple opts specified as well as to configure - #as tables are a heavyweight thing, but handy to nest sometimes - we'll take what we can get - set topt_keys [tcl::dict::keys $::textblock::class::opts_table_defaults] - set switch_keys_valid_topts [punk::lib::lmapflat v $topt_keys {list $v -}] - set switch_keys_valid_topts [lrange $switch_keys_valid_topts 0 end-1] ;#remove last dash - - set copt_keys [tcl::dict::keys $::textblock::class::opts_column_defaults] - set switch_keys_valid_copts [punk::lib::lmapflat v $copt_keys {list $v -}] - set switch_keys_valid_copts [lrange $switch_keys_valid_copts 0 end-1] - - oo::class create [tcl::namespace::current]::table [tcl::string::map [list %topt_keys% $topt_keys %topt_switchkeys% $switch_keys_valid_topts %copt_keys% $copt_keys %copt_switchkeys% $switch_keys_valid_copts] { - - #*** !doctools - #[enum] CLASS [class textblock::class::table] - #[list_begin definitions] - #[para] Create a table suitable for terminal output with various border styles. - #[para] The table can contain multiline cells and ANSI colour and text style attributes. - #[para] Multiple header rows can be configured. - #[para] Header rows can span columns - data rows cannot. - #[para] The restriction on data rows is to maintain compatibility of the data with a Tcl matrix command - #[para] (see get_matrix command) - #[para] Both header and data cells can have various text and blockalignments configured. - # [para] [emph METHODS] - variable o_opts_table ;#options as configured by user (with exception of -ansireset) - variable o_opts_table_effective; #options in effect - e.g with defaults merged in. - - variable o_columndefs - variable o_columndata - variable o_columnstates - variable o_headerdefs - variable o_headerstates - - variable o_rowdefs - variable o_rowstates - - variable o_opts_table_defaults - variable o_opts_header_defaults ;# header data mostly stored in o_columndefs - variable o_opts_column_defaults - variable o_opts_row_defaults - variable TSUB ;#make configurable so user isn't stopped from using our default PUA-unicode char in content (nerdfonts overlap) - variable o_calculated_column_widths - variable o_column_width_algorithm - - - constructor {args} { - #*** !doctools - #[call class::table [method constructor] [arg args]] - #[para] TODO - document the many options - - set o_opts_table_defaults $::textblock::class::opts_table_defaults - set o_opts_column_defaults $::textblock::class::opts_column_defaults - - - if {[llength $args] == 1} { - set args [list -title [lindex $args 0]] - } - if {[llength $args] %2 !=0} { - error "[tcl::namespace::current]::table constructor - unexpected argument count. Require single value being title, or name value pairs" - } - - set o_opts_table $o_opts_table_defaults - set o_opts_table_effective $o_opts_table_defaults - - ##todo - test with punk::lib::show_jump_tables - how? - foreach {k v} $args { - switch -- $k { - %topt_switchkeys% { - tcl::dict::set o_opts_table $k $v - } - default { - error "[tcl::namespace::current]::table unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" - } - } - } - - #foreach {k v} $args { - # #todo - convert to literal switch using tcl::string::map so we don't have to define o_opts_table_defaults here. - # if {$k ni [tcl::dict::keys $o_opts_table_defaults]} { - # error "[tcl::namespace::current]::table unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" - # } - #} - #set o_opts_table [tcl::dict::merge $o_opts_table_defaults $args] - #my configure {*}[tcl::dict::merge $o_opts_table_defaults $args] - - set o_columndefs [tcl::dict::create] - set o_columndata [tcl::dict::create] ;#we store data by column even though it is often added row by row - set o_columnstates [tcl::dict::create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly - set o_headerdefs [tcl::dict::create] ;#by header-row - set o_headerstates [tcl::dict::create] - set o_rowdefs [tcl::dict::create] ;#user requested row data e.g -minheight -maxheight - set o_rowstates [tcl::dict::create] ;#actual row data such as -minheight and -maxheight detected from supplied row data - - set TSUB \uF111 ;#should be BMP PUA code to show as either replacement char or nerdfont glyph. See FSUB for comments regarding choices. - set o_calculated_column_widths [list] - set o_column_width_algorithm "span" - set o_opts_header_defaults [tcl::dict::create\ - -colspans {}\ - -values {}\ - -ansibase {}\ - -ansireset "\x1b\[m"\ - -minheight 1\ - -maxheight ""\ - ] - my configure {*}$o_opts_table - } - - method width_algorithm {{alg ""}} { - if {$alg eq ""} { - return $o_column_width_algorithm - } - if {$alg ne $o_column_width_algorithm} { - #invalidate cached widths - set o_calculated_column_widths [list] - } - set o_column_width_algorithm $alg - } - method Get_seps {} { - set requested_seps [tcl::dict::get $o_opts_table -show_seps] - set requested_seps_h [tcl::dict::get $o_opts_table -show_hseps] - set requested_seps_v [tcl::dict::get $o_opts_table -show_vseps] - set seps $requested_seps - set seps_h $requested_seps_h - set seps_v $requested_seps_v - if {$requested_seps eq ""} { - if {$requested_seps_h eq ""} { - set seps_h 1 - } - if {$requested_seps_v eq ""} { - set seps_v 1 - } - } else { - if {$requested_seps_h eq ""} { - set seps_h $seps - } - if {$requested_seps_v eq ""} { - set seps_v $seps - } - } - return [tcl::dict::create horizontal $seps_h vertical $seps_v] - } - method Get_frametypes {} { - set requested_ft [tcl::dict::get $o_opts_table -frametype] - set requested_ft_header [tcl::dict::get $o_opts_table -frametype_header] - set requested_ft_body [tcl::dict::get $o_opts_table -frametype_body] - set ft $requested_ft - set ft_header $requested_ft_header - set ft_body $requested_ft_body - switch -- $requested_ft { - light { - if {$requested_ft_header eq ""} { - set ft_header heavy - } - if {$requested_ft_body eq ""} { - set ft_body light - } - } - light_b { - if {$requested_ft_header eq ""} { - set ft_header heavy_b - } - if {$requested_ft_body eq ""} { - set ft_body light_b - } - } - light_c { - if {$requested_ft_header eq ""} { - set ft_header heavy_c - } - if {$requested_ft_body eq ""} { - set ft_body light_c - } - } - default { - if {$requested_ft_header eq ""} { - set ft_header $requested_ft - } - if {$requested_ft_body eq ""} { - set ft_body $requested_ft - } - } - } - return [tcl::dict::create header $ft_header body $ft_body] - } - method Set_effective_framelimits {} { - upvar ::textblock::class::opts_table_defaults tdefaults - set default_blims [tcl::dict::get $tdefaults -framelimits_body] - set default_hlims [tcl::dict::get $tdefaults -framelimits_header] - set eff_blims [tcl::dict::get $o_opts_table_effective -framelimits_body] - set eff_hlims [tcl::dict::get $o_opts_table_effective -framelimits_header] - - set requested_blims [tcl::dict::get $o_opts_table -framelimits_body] - set requested_hlims [tcl::dict::get $o_opts_table -framelimits_header] - set blims $eff_blims - set hlims $eff_hlims - switch -- $requested_blims { - "default" { - set blims $default_blims - } - default { - #set blims $requested_blims - set blims [list] - foreach lim $requested_blims { - switch -- $lim { - hl { - lappend blims hlt hlb - } - vl { - lappend blims vll vlr - } - default { - lappend blims $lim - } - } - } - set blims [lsort -unique $blims] - } - } - tcl::dict::set o_opts_table_effective -framelimits_body $blims - switch -- $requested_hlims { - "default" { - set hlims $default_hlims - } - default { - #set hlims $requested_hlims - set hlims [list] - foreach lim $requested_hlims { - switch -- $lim { - hl { - lappend hlims hlt hlb - } - vl { - lappend hlims vll vlr - } - default { - lappend hlims $lim - } - } - } - set hlims [lsort -unique $hlims] - } - } - tcl::dict::set o_opts_table_effective -framelimits_header $hlims - return [tcl::dict::create body $blims header $hlims] - } - method configure {args} { - #*** !doctools - #[call class::table [method configure] [arg args]] - #[para] get or set various table-level properties - - if {![llength $args]} { - return $o_opts_table - } - if {[llength $args] == 1} { - if {[lindex $args 0] in [list %topt_keys%]} { - #query single option - set k [lindex $args 0] - set val [tcl::dict::get $o_opts_table $k] - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - set infodict [tcl::dict::create] - switch -- $k { - -ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder_body - -ansiborder_footer { - tcl::dict::set infodict debug [ansistring VIEW $val] - } - -framemap_body - -framemap_header - -framelimits_body - -framelimits_header { - tcl::dict::set returndict effective [tcl::dict::get $o_opts_table_effective $k] - } - } - tcl::dict::set returndict info $infodict - return $returndict - #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] - } else { - error "textblock::table configure - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_table_defaults]" - } - } - if {[llength $args] %2 != 0} { - error "[tcl::namespace::current]::table configure - unexpected argument count. Require name value pairs" - } - foreach {k v} $args { - switch -- $k { - %topt_switchkeys% {} - default { - error "[tcl::namespace::current]::table configure - unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" - } - } - #if {$k ni [tcl::dict::keys $o_opts_table_defaults]} { - # error "[tcl::namespace::current]::table configure - unrecognised option '$k'. Known values [tcl::dict::keys $o_opts_table_defaults]" - #} - } - set checked_opts [list] - foreach {k v} $args { - switch -- $k { - -ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder-body - -ansiborder_footer { - set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set ansi_codes [list] ; - foreach {pt code} $parts { - if {$pt ne ""} { - #we don't expect plaintext in an ansibase - error "Unable to interpret $k value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" - } - if {$code ne ""} { - lappend ansi_codes $code - } - } - set ansival [punk::ansi::codetype::sgr_merge_singles $ansi_codes] - lappend checked_opts $k $ansival - } - -frametype - -frametype_header - -frametype_body { - #frametype will raise an error if v is not a valid custom dict or one of the known predefined types such as light,heavy,double etc - lassign [textblock::frametype $v] _cat category _type ftype - lappend checked_opts $k $v - } - -framemap_body - -framemap_header { - #upvar ::textblock::class::opts_table_defaults tdefaults - #set default_bmap [tcl::dict::get $tdefaults -framemap_body] - #todo - check keys and map - if {[llength $v] == 1} { - if {$v eq "default"} { - upvar ::textblock::class::opts_table_defaults tdefaults - set default_map [tcl::dict::get $tdefaults $k] - lappend checked_opts $k $default_map - } else { - error "textblock::table::configure invalid $k value $v. Expected the value 'default' or a dict e.g topleft {hl *}" - } - } else { - #safe jumptable test - #dict for {subk subv} $v {} - foreach {subk subv} $v { - switch -- $subk { - topleft - topinner - topright - topsolo - middleleft - middleinner - middleright - middlesolo - bottomleft - bottominner - bottomright - bottomsolo - onlyleft - onlyinner - onlyright - onlysolo {} - default { - error "textblock::table::configure invalid $subk. Known values {topleft topinner topright topsolo middleleft middleinner middleright middlesolo bottomleft bottominner bottomright bottomsolo onlyleft onlyinner onlyright onlysolo}" - } - } - #safe jumptable test - #dict for {seg subst} $subv {} - foreach {seg subst} $subv { - switch -- $seg { - hl - hlt - hlb - vl - vll - vlr - trc - tlc - blc - brc {} - default { - error "textblock::table::configure invalid $subk value $seg. Known values {hl hlt hlb vl vll vlr trc tlc blc brc}" - } - } - } - - } - lappend checked_opts $k $v - } - - } - -framelimits_body - -framelimits_header { - set specific_framelimits [list] - foreach fl $v { - switch -- $fl { - "default" { - lappend specific_framelimits trc hlt tlc vll blc hlb brc vlr - } - hl { - lappend specific_framelimits hlt hlb - } - vl { - lappend specific_framelimits vll vlr - } - hlt - hlb - vll - vlr - trc - tlc - blc - brc { - lappend specific_framelimits $fl - } - default { - error "textblock::table::configure invalid $k '$fl'. Known values {hl hlb hlt vl vll vlr trc tlc blc brc} (or default for all)" - } - } - } - lappend checked_opts $k $specific_framelimits - } - -ansireset { - if {$v eq "\uFFEF"} { - set RST "\x1b\[m" ;#[a] - lappend checked_opts $k $RST - } else { - error "textblock::table::configure -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" - } - } - -show_hseps { - if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" - } - lappend checked_opts $k $v - #these don't affect column width calculations - } - -show_edge { - if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" - } - lappend checked_opts $k $v - #these don't affect column width calculations - except if table -minwidth/-maxwidth come into play - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - } - -show_vseps { - #we allow empty string - so don't use -strict boolean check - if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" - } - #affects width calculations - set o_calculated_column_widths [list] - lappend checked_opts $k $v - } - -minwidth - -maxwidth { - set o_calculated_column_widths [list] - lappend checked_opts $k $v - } - default { - lappend checked_opts $k $v - } - } - } - #all options checked - ok to update o_opts_table and o_opts_table_effective - - #set o_opts_table [tcl::dict::merge $o_opts_table $checked_opts] - foreach {k v} $args { - switch -- $k { - -framemap_header - -framemap_body { - #framemaps don't require setting every key to update. - #e.g configure -framemaps {topleft } - #needs to merge with existing unspecified keys such as topright middleleft etc. - if {$v eq "default"} { - tcl::dict::set o_opts_table $k default - } else { - if {[tcl::dict::get $o_opts_table $k] eq "default"} { - tcl::dict::set o_opts_table $k $v - } else { - tcl::dict::set o_opts_table $k [tcl::dict::merge [tcl::dict::get $o_opts_table $k] $v] - } - } - } - -title { - set twidth [punk::ansi::printing_length $v] - if {[my width] < [expr {$twidth+2}]} { - set o_calculated_column_widths [list] - tcl::dict::set o_opts_table -minwidth [expr {$twidth+2}] - } - tcl::dict::set o_opts_table -title $v - } - default { - tcl::dict::set o_opts_table $k $v - } - } - } - #use values from checked_opts for the effective opts - #safe jumptable test - #dict for {k v} $checked_opts {} - #foreach {k v} $checked_opts {} - tcl::dict::for {k v} $checked_opts { - switch -- $k { - -framemap_body - -framemap_header { - set existing [tcl::dict::get $o_opts_table_effective $k] - #set updated $existing - #dict for {subk subv} $v { - # tcl::dict::set updated $subk $subv - #} - #tcl::dict::set o_opts_table_effective $k $updated - tcl::dict::set o_opts_table_effective $k [tcl::dict::merge $existing $v] - } - -framelimits_body - -framelimits_header { - #my Set_effective_framelimits - tcl::dict::set o_opts_table_effective $k $v - } - default { - tcl::dict::set o_opts_table_effective $k $v - } - } - } - #ansireset exception - tcl::dict::set o_opts_table -ansireset [tcl::dict::get $o_opts_table_effective -ansireset] - return $o_opts_table - } - - #integrate with struct::matrix - allows ::m format 2string $table - method printmatrix {matrix} { - #*** !doctools - #[call class::table [method printmatrix] [arg matrix]] - #[para] clear all table rows and print a matrix into the table - #[para] The rowxcolumn structure must match - - set matrix_rowcount [$matrix rows] - set matrix_colcount [$matrix columns] - set table_colcount [my column_count] - if {$table_colcount == 0} { - for {set c 0} {$c < $matrix_colcount} {incr c} { - my add_column -headers "" - } - } - set table_colcount [my column_count] - if {$table_colcount != $matrix_colcount} { - error "textblock::table::printmatrix column count of table doesn't match column count of matrix" - } - if {[my row_count] > 0} { - my row_clear - } - for {set r 0} {$r < $matrix_rowcount} {incr r} { - my add_row [$matrix get row $r] - } - my print - } - method as_matrix {{cmd ""}} { - #*** !doctools - #[call class::table [method as_matrix] [arg ?cmd?]] - #[para] return a struct::matrix command representing the data portion of the table. - - if {$cmd eq ""} { - set m [struct::matrix] - } else { - set m [struct::matrix $cmd] - } - $m add columns [tcl::dict::size $o_columndata] - $m add rows [tcl::dict::size $o_rowdefs] - tcl::dict::for {k v} $o_columndata { - $m set column $k $v - } - return $m - } - method add_column {args} { - #*** !doctools - #[call class::table [method add_column] [arg args]] - - - if {[llength $args] %2 != 0} { - error "[tcl::namespace::current]::table::add_column unexpected argument count. Require name value pairs. Known options: %copt_keys%" - } - set opts $o_opts_column_defaults - foreach {k v} $args { - switch -- $k { - %copt_switchkeys% { - tcl::dict::set opts $k $v - } - default { - error "[tcl::namespace::current]::table::add_column unknown option '$k'. Known options: %copt_keys%" - } - } - } - set colcount [tcl::dict::size $o_columndefs] - - - tcl::dict::set o_columndata $colcount [list] - #tcl::dict::set o_columndefs $colcount $defaults ;#ensure record exists - tcl::dict::set o_columndefs $colcount $o_opts_column_defaults ;#ensure record exists - - - tcl::dict::set o_columnstates $colcount [tcl::dict::create minwidthbodyseen 0 maxwidthbodyseen 0 maxwidthheaderseen 0] - set prev_calculated_column_widths $o_calculated_column_widths - if {[catch { - my configure_column $colcount {*}$opts - } errMsg]} { - #configure failed - ensure o_columndata and o_columndefs entries are removed - tcl::dict::unset o_columndata $colcount - tcl::dict::unset o_columndefs $colcount - tcl::dict::unset o_columnstates $colcount - #undo cache invalidation - set o_calculated_column_widths $prev_calculated_column_widths - error "add_column failed to configure with supplied options $opts. Err:\n$errMsg" - } - #any add_column that succeeds should invalidate the calculated column widths - set o_calculated_column_widths [list] - set numrows [my row_count] - if {$numrows > 0} { - #fill column with default values - #puts ">>> adding default values for column $colcount" - set dval [tcl::dict::get $opts -defaultvalue] - set width [textblock::width $dval] - tcl::dict::set o_columndata $colcount [lrepeat $numrows $dval] - tcl::dict::set o_columnstates $colcount maxwidthbodyseen $width - tcl::dict::set o_columnstates $colcount minwidthbodyseen $width - } - return $colcount - } - method column_count {} { - #*** !doctools - #[call class::table [method column_count]] - #[para] return the number of columns - return [tcl::dict::size $o_columndefs] - } - method configure_column {index_expression args} { - #*** !doctools - #[call class::table [method configure_column] [arg index_expression] [arg args]] - #[para] - undocumented - - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - error "textblock::table::configure_column - no column defined at index '$cidx'.Use add_column to define columns" - } - if {![llength $args]} { - return [tcl::dict::get $o_columndefs $cidx] - } else { - if {[llength $args] == 1} { - if {[lindex $args 0] in [list %copt_keys%]} { - #query single option - set k [lindex $args 0] - set val [tcl::dict::get $o_columndefs $cidx $k] - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - set infodict [tcl::dict::create] - switch -- $k { - -ansibase { - tcl::dict::set infodict debug [ansistring VIEW $val] - } - } - tcl::dict::set returndict info $infodict - return $returndict - } else { - error "textblock::table configure_column - unrecognised option '[lindex $args 0]'. Known values %copt_keys%" - } - } - if {[llength $args] %2 != 0} { - error "textblock::table configure_column unexpected argument count. Require name value pairs. Known options: %copt_keys%" - } - foreach {k v} $args { - switch -- $k { - %copt_switchkeys% {} - default { - error "[tcl::namespace::current]::table configure_column unknown option '$k'. Known options: %copt_keys%" - } - } - } - set checked_opts [tcl::dict::get $o_columndefs $cidx] ;#copy of current state - - set hstates $o_headerstates ;#operate on a copy - set colstate [tcl::dict::get $o_columnstates $cidx] - set args_got_headers 0 - set args_got_header_colspans 0 - foreach {k v} $args { - switch -- $k { - -headers { - set args_got_headers 1 - set i 0 - set maxseen 0 ;#don't compare with cached colstate maxwidthheaderseen - we have all the headers for the column right here and need to refresh the colstate maxwidthheaderseen values completely. - foreach hdr $v { - set currentmax [my header_height_calc $i $cidx] ;#exclude current column - ie look at heights for this header in all other columns - #set this_header_height [textblock::height $hdr] - lassign [textblock::size $hdr] _w this_header_width _h this_header_height - - if {$this_header_height >= $currentmax} { - tcl::dict::set hstates $i maxheightseen $this_header_height - } else { - tcl::dict::set hstates $i maxheightseen $currentmax - } - if {$this_header_width >= $maxseen} { - set maxseen $this_header_width - } - #if {$this_header_width > [tcl::dict::get $colstate maxwidthheaderseen]} { - # tcl::dict::set colstate maxwidthheaderseen $this_header_width - #} - incr i - } - tcl::dict::set colstate maxwidthheaderseen $maxseen - #review - we could avoid some recalcs if we check current width range compared to previous - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - tcl::dict::set checked_opts $k $v - } - -header_colspans { - 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 '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]} { - error "configure_column $cidx -header_colspans. Only [tcl::dict::size $cspans] headers exist. Too many values supplied" - } - foreach s $v { - 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 'any' or a positive integer" - } - } else { - 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 "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 "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 "any"} { - set remaining "any" - } else { - if {$remaining eq "any"} { - if {$span ne "0"} { - #a previous column has ended the 'any' span - set remaining [expr {$span -1}] - } - } else { - if {$span eq "0"} { - incr remaining -1 - } else { - set remaining [expr {$span -1}] - } - #allow to go negative - } - } - } - if {$remaining eq "any"} { - #any int >0 ok - what about 'any' immediately following any? - } else { - if {$remaining > 0} { - if {$s ne "0" && $s ne ""} { - error "configure_column $cidx -header_colspans bad span $s for header '$h'. Remaining span is '$remaining' - so a zero colspan is required" - } - } else { - if {$s == 0} { - error "configure_column $cidx -header_colspans bad span $s for header '$h'. No span in place - need >=1 or 'any'" - } - } - } - #} - } - incr h - } - #todo - avoid recalc if no change - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - tcl::dict::set checked_opts $k $v - } - -minwidth { - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - tcl::dict::set checked_opts $k $v - } - -maxwidth { - set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed - tcl::dict::set checked_opts $k $v - } - -ansibase { - set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set col_ansibase_items [list] ; - foreach {pt code} $parts { - if {$pt ne ""} { - #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" - } - if {$code ne ""} { - lappend col_ansibase_items $code - } - } - set col_ansibase [punk::ansi::codetype::sgr_merge_singles $col_ansibase_items] - tcl::dict::set checked_opts $k $col_ansibase - } - -ansireset { - if {$v eq "\uFFEF"} { - tcl::dict::set checked_opts $k "\x1b\[m" ;# [a] - } else { - error "textblock::table::configure_column -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" - } - } - -blockalign - -textalign { - switch -- $v { - left - right { - tcl::dict::set checked_opts $k $v - } - centre - centre { - tcl::dict::set checked_opts $k centre - } - } - } - default { - tcl::dict::set checked_opts $k $v - } - } - } - #args checked - ok to update headerstates, headerdefs and columndefs and columnstates - tcl::dict::set o_columndefs $cidx $checked_opts - set o_headerstates $hstates - dict for {hidx hstate} $hstates { - #configure_header - if {![dict exists $o_headerdefs $hidx]} { - #remove calculated members -values -colspans - set hdefaults [dict remove $o_opts_header_defaults -values -colspans] - dict set o_headerdefs $hidx $hdefaults - } - } - - tcl::dict::set o_columnstates $cidx $colstate - - if {$args_got_headers} { - #if the headerlist length for this column has shrunk,and it was the longest - we may now have excess entries in o_headerstates - set zero_heights [list] - tcl::dict::for {hidx _v} $o_headerstates { - #pass empty string for exclude_column so we don't exclude our own column - if {[my header_height_calc $hidx ""] == 0} { - lappend zero_heights $hidx - } - } - foreach zidx $zero_heights { - tcl::dict::unset o_headerstates $zidx - } - } - if {$args_got_headers || $args_got_header_colspans} { - #check and adjust header_colspans for all columns - - } - - return [tcl::dict::get $o_columndefs $cidx] - } - } - - method header_count {} { - #*** !doctools - #[call class::table [method header_count]] - #[para] return the number of header rows - return [tcl::dict::size $o_headerstates] - } - method header_count_calc {} { - set max_headers 0 - tcl::dict::for {k cdef} $o_columndefs { - set num_headers [llength [tcl::dict::get $cdef -headers]] - set max_headers [expr {max($max_headers,$num_headers)}] - } - return $max_headers - } - method header_height {header_index} { - #*** !doctools - #[call class::table [method header_height] [arg header_index]] - #[para] return the height of a header as the number of content-lines - - set idx [lindex [tcl::dict::keys $o_headerstates $header_index]] - return [tcl::dict::get $o_headerstates $idx maxheightseen] - } - - #review - use maxwidth (considering colspans) of each column to determine height after wrapping - # -need to consider whether vertical expansion allowed / maxheight? - method header_height_calc {header_index {exclude_column ""}} { - set dataheight 0 - if {$exclude_column eq ""} { - set exclude_colidx "" - } else { - set exclude_colidx [lindex [tcl::dict::keys $o_columndefs] $exclude_column] - } - tcl::dict::for {cidx cdef} $o_columndefs { - if {$exclude_colidx == $cidx} { - continue - } - set headerlist [tcl::dict::get $cdef -headers] - if {$header_index < [llength $headerlist]} { - set this_height [textblock::height [lindex $headerlist $header_index]] - set dataheight [expr {max($dataheight,$this_height)}] - } - } - return $dataheight - } - - #return a dict keyed on header index with values representing colspans - #e.g - # 0 {any 0 0 0} 1 {1 1 1 1} 2 {2 0 1 1} 3 {3 0 0 1} - # - method header_colspans {} { - #*** !doctools - #[call class::table [method header_colspans]] - #[para] Show the colspans configured for all headers - - #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] - set colspans_for_column [tcl::dict::get $cdef -header_colspans] - for {set h 0} {$h < $num_headers} {incr h} { - set headerspans [punk::lib::dict_getdef $colspans_by_header $h [list]] - set defined_span [lindex $colspans_for_column $h] - set i 0 - set spanremaining [lindex $headerspans 0] - if {$spanremaining ne "any"} { - if {$spanremaining eq ""} { - set spanremaining 1 - } - incr spanremaining -1 - } - foreach s $headerspans { - if {$s eq "any"} { - set spanremaining "any" - } elseif {$s == 0} { - if {$spanremaining ne "any"} { - incr spanremaining -1 - } - } else { - set spanremaining [expr {$s - 1}] - } - incr i - } - if {$defined_span eq ""} { - if {$spanremaining eq "0"} { - lappend headerspans 1 - } else { - #"any" or an integer - lappend headerspans 0 - } - } else { - lappend headerspans $defined_span - } - tcl::dict::set colspans_by_header $h $headerspans - } - } - 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 - } - - method configure_header {index_expression args} { - #*** !doctools - #[call class::table [method configure_header]] - #[para] - configure header row-wise - - #the header data being configured or returned here is mostly derived from the column defs and if necessary written to the column defs. - #It can also be set column by column - but it is much easier (especially for colspans) to configure them on a header-row basis - #e.g o_headerstates: 0 {maxheightseen 1} 1 {maxheightseen 2} - set num_headers [my header_count_calc] - set hidx [lindex [tcl::dict::keys $o_headerstates] $index_expression] - if {$hidx eq ""} { - error "textblock::table::configure_header - no header row defined at index '$index_expression'." - } - if {$hidx > $num_headers -1} { - #assert - shouldn't happen - error "textblock::table::configure_header error headerstates data is out of sync" - } - - if {![llength $args]} { - set colspans_by_header [my header_colspans] - set result [tcl::dict::create] - tcl::dict::set result -colspans [tcl::dict::get $colspans_by_header $hidx] - set header_row_items [list] - tcl::dict::for {cidx cdef} $o_columndefs { - set colheaders [tcl::dict::get $cdef -headers] - set relevant_header [lindex $colheaders $hidx] - #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns - lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. - } - tcl::dict::set result -values $header_row_items - - #review - ensure always a headerdef record for each header? - if {[tcl::dict::exists $o_headerdefs $hidx]} { - set result [tcl::dict::merge $result [tcl::dict::get $o_headerdefs $hidx]] - } else { - #warn for now - puts stderr "no headerdef record for header $hidx" - } - return $result - } - if {[llength $args] == 1} { - if {[lindex $args 0] in [tcl::dict::keys $o_opts_header_defaults]} { - #query single option - set k [lindex $args 0] - #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] - tcl::dict::for {cidx cdef} $o_columndefs { - set colheaders [tcl::dict::get $cdef -headers] - set relevant_header [lindex $colheaders $hidx] - #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns - lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. - - } - set val $header_row_items - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - } - -colspans { - set colspans_by_header [my header_colspans] - set result [tcl::dict::create] - set val [tcl::dict::get $colspans_by_header $hidx] - #ansireset not required - set returndict [tcl::dict::create option $k value $val] - } - -ansibase { - set val ??? - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - tcl::dict::set infodict debug [ansistring VIEW $val] - } - } - tcl::dict::set returndict info $infodict - return $returndict - #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] - } else { - error "textblock::table configure_header - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_header_defaults]" - } - } - if {[llength $args] %2 != 0} { - error "textblock::table configure_header incorrect number of options following index_expression. Require name value pairs. Known options: [tcl::dict::keys $o_opts_header_defaults]" - } - foreach {k v} $args { - if {$k ni [tcl::dict::keys $o_opts_header_defaults]} { - error "[tcl::namespace::current]::table configure_row unknown option '$k'. Known options: [tcl::dict::keys $o_opts_header_defaults]" - } - } - - set checked_opts [list] - #safe jumptable test - #dict for {k v} $args {} - foreach {k v} $args { - switch -- $k { - -ansibase { - set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set header_ansibase_items [list] ; - foreach {pt code} $parts { - if {$pt ne ""} { - #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" - } - if {$code ne ""} { - lappend header_ansibase_items $code - } - } - set header_ansibase [punk::ansi::codetype::sgr_merge_singles $header_ansibase_items] - lappend checked_opts $k $header_ansibase - } - -ansireset { - if {$v eq "\uFFEF"} { - lappend checked_opts $k "\x1b\[m" ;# [a] - } else { - error "textblock::table::configure_header -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" - } - } - -values { - if {[llength $v] > [tcl::dict::size $o_columndefs]} { - error "textblock::table::configure_header -values length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])" - } - lappend checked_opts $k $v - } - -colspans { - set numcols [tcl::dict::size $o_columndefs] - if {[llength $v] > $numcols} { - error "textblock::table::configure_header -colspans length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])" - } - if {[llength $v] < $numcols} { - puts stderr "textblock::table::configure_header warning - only [llength $v] spans specified for [tcl::dict::size $o_columndefs] columns." - puts stderr "It is recommended to set all spans explicitly. (auto-calc not implemented)" - } - if {[llength $v]} { - set firstspan [lindex $v 0] - set first_is_ok 0 - 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 \"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 "any"} { - incr remaining -1 - } - set spanview $v - set sidx 1 - #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 "any"} { - if {$span eq "any"} { - set remaining "any" - } elseif {$span > 0} { - #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 \"any\".[a] $spanview" - } - set remaining $span - incr remaining -1 - } else { - #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 \"any\" value.[a] $spanview" - } else { - incr remaining -1 - } - } else { - if {$remaining eq "0"} { - #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 \"any\".[a] $spanview" - } - set remaining $span - if {$remaining ne "any"} { - incr remaining -1 - } - } else { - lset spanview $sidx [a+ web-red]$span[a] - error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require zero value span.[a] $spanview" - } - } - } - incr sidx - } - } - #empty -colspans list should be ok - - #error "sorry - -colspans not yet implemented for header rows - set manually in vertical order via configure_column for now" - lappend checked_opts $k $v - } - default { - lappend checked_opts $k $v - } - } - } - - #configured opts all good - #safe jumptable test - #dict for {k v} $checked_opts {} - #foreach {k v} $checked_opts {} - - # headerdefs excludes -values and -colspans - set update_hdefs [tcl::dict::get $o_headerdefs $hidx] - - tcl::dict::for {k v} $checked_opts { - switch -- $k { - -values { - set c 0 - foreach hval $v { - #retrieve -headers from relevant col, insert at header index, and write back. - set thiscol_headers_vertical [tcl::dict::get $o_columndefs $c -headers] - set missing [expr {($hidx +1) - [llength $thiscol_headers_vertical]}] - if {$missing > 0} { - lappend thiscol_headers_vertical {*}[lrepeat $missing ""] - } - lset thiscol_headers_vertical $hidx $hval - tcl::dict::set o_columndefs $c -headers $thiscol_headers_vertical - #invalidate column width cache - set o_calculated_column_widths [list] - # -- -- -- -- -- -- - #also update maxwidthseen & maxheightseen - set i 0 - set maxwidthseen 0 - #set maxheightseen 0 - foreach hdr $thiscol_headers_vertical { - lassign [textblock::size $hdr] _w this_header_width _h this_header_height - set maxheightseen [punk::lib::dict_getdef $o_headerstates $i maxheightseen 0] - if {$this_header_height >= $maxheightseen} { - tcl::dict::set o_headerstates $i maxheightseen $this_header_height - } else { - tcl::dict::set o_headerstates $i maxheightseen $maxheightseen - } - if {$this_header_width >= $maxwidthseen} { - set maxwidthseen $this_header_width - } - incr i - } - tcl::dict::set o_columnstates $c maxwidthheaderseen $maxwidthseen - # -- -- -- -- -- -- - incr c - } - } - -colspans { - #sequence has been verified above - we need to split it and store across columns - set c 0 ;#column index - foreach span $v { - set colspans [tcl::dict::get $o_columndefs $c -header_colspans] - if {$hidx > [llength $colspans]-1} { - set colspans_by_header [my header_colspans] - #puts ">>>>>?$colspans_by_header" - #we are allowed to lset only one beyond the current length to append - #but there may be even less or no entries present in a column - # - the ability to underspecify and calculate the missing values makes setting the values complicated. - #use the header_colspans calculation to update only those entries necessary - set spanlist [list] - for {set h 0} {$h < $hidx} {incr h} { - set cspans [tcl::dict::get $colspans_by_header $h] - set requiredval [lindex $cspans $c] - lappend spanlist $requiredval - } - tcl::dict::set o_columndefs $c -header_colspans $spanlist - - set colspans [tcl::dict::get $o_columndefs $c -header_colspans] - } - - lset colspans $hidx $span - tcl::dict::set o_columndefs $c -header_colspans $colspans - incr c - } - } - default { - dict set update_hdefs $k $v - } - } - } - set opt_minh [tcl::dict::get $update_hdefs -minheight] - set opt_maxh [tcl::dict::get $update_hdefs -maxheight] - - #todo - allow zero values to hide/collapse - # - see also configure_row - if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} { - error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)" - } - if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} { - error "[tcl::namespace::current]::table::configure_header error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)" - } - if {$opt_maxh ne "" && $opt_maxh < $opt_minh} { - error "[tcl::namespace::current]::table::configure_header error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'" - } - - #set o_headerstate $hidx -minheight? -maxheight? ??? - tcl::dict::set o_headerdefs $hidx $update_hdefs - } - - method add_row {valuelist args} { - #*** !doctools - #[call class::table [method add_row]\ - # [arg valuelist]\ - # [opt "[option -minheight] [arg int_minheight]"]\ - # [opt "[option -maxheight] [arg int_maxheight]"]\ - # [opt "[option -ansibase] [arg ansicode]"]\ - #] - if {[tcl::dict::size $o_columndefs] > 0 && ([llength $valuelist] && [llength $valuelist] != [tcl::dict::size $o_columndefs])} { - set msg "" - append msg "add_row - invalid number ([llength $valuelist]) of values in row - Must match existing column count: [tcl::dict::size $o_columndefs]" \n - append msg "rowdata: $valuelist" - error $msg - } - if {[tcl::dict::size $o_columndefs] == 0 && ![llength $valuelist]} { - error "add_row - no values supplied, and no columns defined, so cannot use default column values" - } - - set defaults [tcl::dict::create\ - -minheight 1\ - -maxheight ""\ - -ansibase ""\ - -ansireset "\uFFEF"\ - ] - set o_opts_row_defaults $defaults - - if {[llength $args] %2 !=0} { - error "[tcl::namespace::current]::table::add_row unexpected argument count. Require name value pairs. Known options: [tcl::dict::keys $defaults]" - } - #safe jumptable test - #dict for {k v} $args {} - foreach {k v} $args { - switch -- $k { - -minheight - -maxheight - -ansibase - -ansireset {} - default { - error "Invalid option '$k' Known options: [tcl::dict::keys $defaults] (-ansireset is read-only)" - } - } - } - set opts [tcl::dict::merge $defaults $args] - - set auto_columns 0 - if {[tcl::dict::size $o_columndefs] == 0} { - set auto_columns 1 - #no columns defined - auto define with defaults for each column in first supplied row - #auto define columns only valid if no existing columns - #the autocolumns must be added before configure_row - but if configure_row fails - we need to remove them! - foreach el $valuelist { - my add_column - } - } else { - if {![llength $valuelist]} { - tcl::dict::for {k coldef} $o_columndefs { - lappend valuelist [tcl::dict::get $coldef -defaultvalue] - } - } - } - set rowcount [tcl::dict::size $o_rowdefs] - tcl::dict::set o_rowdefs $rowcount $defaults ;# ensure record exists before configure - - if {[catch { - my configure_row $rowcount {*}$opts - } errMsg]} { - #undo anything we saved before configure_row - tcl::dict::unset o_rowdefs $rowcount - #remove auto_columns - if {$auto_columns} { - set o_columndata [tcl::dict::create] - set o_columndefs [tcl::dict::create] - set o_columnstate [tcl::dict::create] - } - error "add_row failed to configure with supplied options $opts. Err:\n$errMsg" - } - - - set c 0 - set max_height_seen 1 - foreach v $valuelist { - set prev_maxwidth [tcl::dict::get $o_columnstates $c maxwidthbodyseen] - set prev_minwidth [tcl::dict::get $o_columnstates $c minwidthbodyseen] - - tcl::dict::lappend o_columndata $c $v - lassign [textblock::size_as_list $v] valwidth valheight - if {$valheight > $max_height_seen} { - set max_height_seen $valheight - } - if {$valwidth > [tcl::dict::get $o_columnstates $c maxwidthbodyseen]} { - tcl::dict::set o_columnstates $c maxwidthbodyseen $valwidth - } - if {$valwidth < [tcl::dict::get $o_columnstates $c minwidthbodyseen]} { - tcl::dict::set o_columnstates $c minwidthbodyseen $valwidth - } - - if {[tcl::dict::get $o_columnstates $c maxwidthbodyseen] > $prev_maxwidth || [tcl::dict::get $o_columnstates $c minwidthbodyseen] < $prev_minwidth} { - #invalidate calculated column width cache if any new value was outside the previous range of widths - set o_calculated_column_widths [list] - } - incr c - } - - set opt_maxh [tcl::dict::get $o_rowdefs $rowcount -maxheight] - if {$opt_maxh ne ""} { - tcl::dict::set o_rowstates $rowcount -maxheight [expr {min($opt_maxh,$max_height_seen)}] - } else { - tcl::dict::set o_rowstates $rowcount -maxheight $max_height_seen - } - - return $rowcount - } - method configure_row {index_expression args} { - #*** !doctools - #[call class::table [method configure_row]\ - # [arg index_expression]\ - # [opt "[option -minheight] [arg int_minheight]"]\ - # [opt "[option -maxheight] [arg int_maxheight]"]\ - # [opt "[option -ansibase] [arg ansicode]"]\ - #] - set ridx [lindex [tcl::dict::keys $o_rowdefs] $index_expression] - if {$ridx eq ""} { - error "textblock::table::configure_row - no row defined at index '$ridx'.Use add_row to define rows" - } - if {![llength $args]} { - return [tcl::dict::get $o_rowdefs $ridx] - } - if {[llength $args] == 1} { - if {[lindex $args 0] in [tcl::dict::keys $o_opts_row_defaults]} { - #query single option - set k [lindex $args 0] - set val [tcl::dict::get $o_rowdefs $ridx $k] - set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] - set infodict [tcl::dict::create] - switch -- $k { - -ansibase { - tcl::dict::set infodict debug [ansistring VIEW $val] - } - } - tcl::dict::set returndict info $infodict - return $returndict - #return [tcl::dict::create option $k value $val ansireset "\x1b\[m" info $infodict] - } else { - error "textblock::table configure_row - unrecognised option '[lindex $args 0]'. Known values [tcl::dict::keys $o_opts_row_defaults]" - } - } - if {[llength $args] %2 != 0} { - error "textblock::table configure_row incorrect number of options following index_expression. Require name value pairs. Known options: [tcl::dict::keys $o_opts_row_defaults]" - } - foreach {k v} $args { - if {$k ni [tcl::dict::keys $o_opts_row_defaults]} { - error "[tcl::namespace::current]::table configure_row unknown option '$k'. Known options: [tcl::dict::keys $o_opts_row_defaults]" - } - } - set checked_opts [list] - foreach {k v} $args { - switch -- $k { - -ansibase { - set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set row_ansibase_items [list] ; - foreach {pt code} $parts { - if {$pt ne ""} { - #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" - } - if {$code ne ""} { - lappend row_ansibase_items $code - } - } - set row_ansibase [punk::ansi::codetype::sgr_merge_singles $row_ansibase_items] - lappend checked_opts $k $row_ansibase - } - -ansireset { - if {$v eq "\uFFEF"} { - lappend checked_opts $k "\x1b\[m" ;# [a] - } else { - error "textblock::table::configure_row -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" - } - } - default { - lappend checked_opts $k $v - } - } - } - - set current_opts [tcl::dict::get $o_rowdefs $ridx] - set opts [tcl::dict::merge $current_opts $checked_opts] - - #check minheight and maxheight together - set opt_minh [tcl::dict::get $opts -minheight] - set opt_maxh [tcl::dict::get $opts -maxheight] - - #todo - allow zero values to hide/collapse rows as is possible with columns - if {![tcl::string::is integer $opt_minh] || ($opt_maxh ne "" && ![tcl::string::is integer -strict $opt_maxh])} { - error "[tcl::namespace::current]::table::configure_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must be integers greater than or equal to 1 (for now)" - } - if {$opt_minh < 1 || ($opt_maxh ne "" && $opt_maxh < 1)} { - error "[tcl::namespace::current]::table::configure_row error -minheight '$opt_minh' and -maxheight '$opt_maxh' must both be 1 or greater (for now)" - } - if {$opt_maxh ne "" && $opt_maxh < $opt_minh} { - error "[tcl::namespace::current]::table::configure_row error -maxheight '$opt_maxh' must greater than -minheight '$opt_minh'" - } - tcl::dict::set o_rowstates $ridx -minheight $opt_minh - - - tcl::dict::set o_rowdefs $ridx $opts - } - method row_count {} { - #*** !doctools - #[call class::table [method row_count]] - #[para] return the number of data rows in the table. - return [tcl::dict::size $o_rowdefs] - } - method row_clear {} { - #*** !doctools - #[call class::table [method row_clear]] - #[para] Remove all rows without resetting column data. - #[para] When adding new rows the number of entries will need to match the existing column count. - set o_rowdefs [tcl::dict::create] - set o_rowstates [tcl::dict::create] - #The data values are stored by column regardless of whether added row by row - tcl::dict::for {cidx records} $o_columndata { - tcl::dict::set o_columndata $cidx [list] - #reset only the body fields in o_columnstates - tcl::dict::set o_columnstates $cidx minwidthbodyseen 0 - tcl::dict::set o_columnstates $cidx maxwidthbodyseen 0 - } - set o_calculated_column_widths [list] - } - method clear {} { - #*** !doctools - #[call class::table [method clear]] - #[para] Remove all row and column data. - #[para] If a subsequent call to add_row is made it can contain any number of values. - #[para] Further calls to add_row will need to contain the same number of values - #[para] as the first call unless default values have been set for the missing columns (review - in flux). - my row_clear - set o_columndefs [tcl::dict::create] - set o_columndata [tcl::dict::create] - set o_columnstates [tcl::dict::create] - } - - - - #method Get_columns_by_name {namematch_list} { - #} - - #specify range with x..y - method Get_columns_by_indices {index_list} { - foreach spec $index_list { - if {[tcl::string::is integer -strict $c]} { - set colidx $c - } else { - tcl::dict::for {colidx coldef} $o_columndefs { - #if {[tcl::string::match x x]} {} - } - } - } - } - method Get_boxlimits_and_joins {position fname_body} { - #fname_body will be "custom" or one of the predefined types light,heavy etc - switch -- $position { - left { - return [tcl::dict::create \ - boxlimits [list hlb blc vll]\ - boxlimits_top [list hlb blc vll hlt tlc]\ - joins [list down]\ - bodyjoins [list down-$fname_body]\ - ] - } - inner { - return [tcl::dict::create \ - boxlimits [list hlb blc vll]\ - boxlimits_top [list hlb blc vll hlt tlc]\ - joins [list down left]\ - bodyjoins [list left down-$fname_body] - ] - } - right { - return [tcl::dict::create \ - boxlimits [list hlb blc vll vlr brc]\ - boxlimits_top [list hlb blc vll vlr brc hlt tlc trc]\ - joins [list down left]\ - bodyjoins [list left down-$fname_body]\ - ] - } - solo { - return [tcl::dict::create \ - boxlimits [list hlb blc vll vlr brc]\ - boxlimits_top [list hlb blc vll vlr brc hlt tlc trc]\ - joins [list down]\ - bodyjoins [list down-$fname_body]\ - ] - } - default { - error "Get_boxlimits_and_joins unrecognised position '$position' expected: left inner right solo" - } - } - } - method Get_boxlimits_and_joins1 {position fname_body} { - #fname_body will be "custom" or one of the predefined types light,heavy etc - switch -- $position { - left { - #set header_boxlimits {hlb hlt tlc blc vll} - set header_body_joins [list down-$fname_body] - set boxlimits_position [list hlb blc vll] - #set boxlimits_toprow [concat $boxlimits_position {hlt tlc}] - set boxlimits_toprow [list hlb blc vll hlt tlc] - set joins [list down] - } - inner { - #set header_boxlimits {hlb hlt tlc blc vll} - set header_body_joins [list left down-$fname_body] - set boxlimits_position [list hlb blc vll] - #set boxlimits_toprow [concat $boxlimits_position {hlt tlc}] - set boxlimits_toprow [list hlb blc vll hlt tlc] - set joins [list down left] - } - right { - #set header_boxlimits {hlb hlt tlc blc vll vlr trc brc} - set header_body_joins [list left down-$fname_body] - set boxlimits_position [list hlb blc vll vlr brc] - #set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}] - set boxlimits_toprow [list hlb blc vll vlr brc hlt tlc trc] - set joins [list down left] - } - solo { - #set header_boxlimits {hlb hlt tlc blc vll vlr trc brc} - set header_body_joins [list down-$fname_body] - set boxlimits_position [list hlb blc vll vlr brc] - #set boxlimits_toprow [concat $boxlimits_position {hlt tlc trc}] - set boxlimits_toprow [list hlb blc vll vlr brc hlt tlc trc] - set joins [list down] - } - } - return [tcl::dict::create boxlimits $boxlimits_position boxlimits_top $boxlimits_toprow joins $joins bodyjoins $header_body_joins ] - } - method get_column_by_index {index_expression args} { - #puts "+++> get_column_by_index $index_expression $args [tcl::namespace::current]" - #index_expression may be something like end-1 or 2+2 - we can't directly use it as a lookup for dicts. - set opts [tcl::dict::create\ - -position "inner"\ - -return "string"\ - ] - foreach {k v} $args { - switch -- $k { - -position - -return { - tcl::dict::set opts $k $v - } - default { - error "[tcl::namespace::current]::table::get_column_by_index error invalid option '$k'. Known options [tcl::dict::keys $opts]" - } - } - } - set opt_posn [tcl::dict::get $opts -position] - set opt_return [tcl::dict::get $opts -return] - - switch -- $opt_posn { - left - inner - right - solo {} - default { - error "[tcl::namespace::current]::table::get_column_by_index error invalid value '$opt_posn' for -position. Valid values: [list left inner right solo]" - } - } - switch -- $opt_return { - string - dict {} - default { - error "[tcl::namespace::current]::table::get_column_by_index error invalid value '$opt_return' for -return. Valid values: string dict" - } - } - - set columninfo [my get_column_cells_by_index $index_expression] - set header_list [tcl::dict::get $columninfo headers] - #puts "===== header_list: $header_list" - set cells [tcl::dict::get $columninfo cells] - - set topt_show_header [tcl::dict::get $o_opts_table -show_header] - if {$topt_show_header eq ""} { - set allheaders 0 - set all_cols [tcl::dict::keys $o_columndefs] - foreach c $all_cols { - incr allheaders [llength [tcl::dict::get $o_columndefs $c -headers]] - } - if {$allheaders == 0} { - set do_show_header 0 - } else { - set do_show_header 1 - } - } else { - set do_show_header $topt_show_header - } - set topt_show_footer [tcl::dict::get $o_opts_table -show_footer] - - - set output "" - set part_header "" - set part_body "" - set part_footer "" - - set boxlimits "" - set joins "" - set header_boxlimits [list] - set header_body_joins [list] - - - set ftypes [my Get_frametypes] - set ftype_body [tcl::dict::get $ftypes body] - if {[llength $ftype_body] >= 2} { - set fname_body "custom" - } else { - set fname_body $ftype_body - } - set ftype_header [tcl::dict::get $ftypes header] - if {[llength $ftype_header] >= 2} { - set fname_header "custom" - } else { - set fname_header $ftype_header - } - - set limj [my Get_boxlimits_and_joins $opt_posn $fname_body] - set header_body_joins [tcl::dict::get $limj bodyjoins] - set joins [tcl::dict::get $limj joins] - set boxlimits_position [tcl::dict::get $limj boxlimits] - set boxlimits_toprow [tcl::dict::get $limj boxlimits_top] - #use struct::set instead of simple for loop - will be faster at least when critcl available - set boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_position] - set boxlimits_headerless [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_toprow] - set header_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $boxlimits_position] - set header_boxlimits_toprow [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $boxlimits_toprow] - - set fmap [tcl::dict::get $o_opts_table_effective -framemap_body] - set hmap [tcl::dict::get $o_opts_table_effective -framemap_header] - - #if {![tcl::dict::get $o_opts_table -show_edge]} { - # set body_edgemap [textblock::class::table_edge_map ""] - # dict for {k v} $fmap { - # #tcl::dict::set fmap $k [tcl::dict::merge $v [tcl::dict::get $body_edgemap $k]] - # } - # set header_edgemap [textblock::class::header_edge_map ""] - # dict for {k v} $hmap { - # #tcl::dict::set hmap $k [tcl::dict::merge $v [tcl::dict::get $header_edgemap $k]] - # } - #} - set sep_elements_horizontal $::textblock::class::table_hseps - set sep_elements_vertical $::textblock::class::table_vseps - - set topmap [tcl::dict::get $fmap top$opt_posn] - set botmap [tcl::dict::get $fmap bottom$opt_posn] - set midmap [tcl::dict::get $fmap middle$opt_posn] - set onlymap [tcl::dict::get $fmap only$opt_posn] - - set hdrmap [tcl::dict::get $hmap only${opt_posn}] - - set topseps_h [tcl::dict::get $sep_elements_horizontal 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] - - #top should work for all header rows regarding vseps - as we only use it to reduce the box elements, and lower headers have same except for tlc which isn't present anyway - set headerseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] - - lassign [my Get_seps] _h show_seps_h _v show_seps_v - set return_headerheight 0 - set return_headerwidth 0 - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - - set colwidth [my column_width $cidx] - - set col_blockalign [tcl::dict::get $o_columndefs $cidx -blockalign] - - if {$do_show_header} { - #puts "boxlimitsinfo header $opt_posn: -- boxlimits $header_boxlimits -- boxmap $hdrmap" - set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] ;#merged to single during configure - set ansiborder_header [tcl::dict::get $o_opts_table -ansiborder_header] - if {[tcl::dict::get $o_opts_table -frametype_header] eq "block"} { - set extrabg [punk::ansi::codetype::sgr_merge_singles [list $ansibase_header] -filter_fg 1] - set ansiborder_final $ansibase_header$ansiborder_header$extrabg - } else { - set ansiborder_final $ansibase_header$ansiborder_header - } - set RST [punk::ansi::a] - - - set hcolwidth $colwidth - #set hcolwidth [my column_width_configured $cidx] - set hcell_line_blank [tcl::string::repeat " " $hcolwidth] - - 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 span_extend_map [tcl::dict::create \ - vll " "\ - tlc [tcl::dict::get $fdef_header hlt]\ - blc [tcl::dict::get $fdef_header hlb]\ - ] - - - #used for colspan-zero header frames - set framesub_map [list hl $TSUB vll $TSUB vlr $TSUB tlc $TSUB blc $TSUB trc $TSUB brc $TSUB] ;# a debug test - - set hrow 0 - set hmax [expr {[llength $header_list] -1}] - foreach header $header_list { - set headerspans [tcl::dict::get $all_colspans $hrow] - set this_span [lindex $headerspans $cidx] - #set hval $ansibase_header$header ;#no reset - set hval $header - set rowh [my header_height $hrow] - - if {$hrow == 0} { - set hlims $header_boxlimits_toprow - set rowpos "top" - if {$hrow == $hmax} { - set rowpos "only" - } - } else { - set hlims $header_boxlimits - set rowpos "middle" - if {$hrow == $hmax} { - set rowpos "bottom" - } - } - if {!$show_seps_v} { - set hlims [struct::set difference $hlims $headerseps_v] - } - if {$hrow == $hmax} { - set header_joins $header_body_joins - } else { - set header_joins $joins - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] - } - #puts ">>> headerspans: $headerspans cidx: $cidx" - - #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} { - if {[tcl::dict::exists $all_colspans [expr {$hrow+1}]]} { - set next_spanlist [tcl::dict::get $all_colspans [expr {$hrow+1}]] - set spanbelow [lindex $next_spanlist $cidx] - if {$spanbelow == 0} { - #we don't want a down-join for blc - use a framedef with only left joins - tcl::dict::set startmap blc [tcl::dict::get $framedef_leftbox blc] - } - } else { - set next_spanlist [list] - } - } - - #supporting wrapping in headers might be a step too difficult for little payoff. - #we would need a flag to enable/disable - plus language-based wrapping alg (see tcllib) - #The interaction with colspans and width calculations makes it likely to have a heavy performance impact and make the code even more complex. - #May be better to require user to pre-wrap as needed - ##set hval [textblock::renderspace -width $colwidth -wrap 1 "" $hval] - - #review - contentwidth of hval can be greater than $colwidth+2 - if so frame function will detect and frame_cache will not be used - #This ellipsis 0 makes a difference (unwanted ellipsis at rhs of header column that starts span) - - # -width is always +2 - as the boxlimits take into account show_vseps and show_edge - #set header_cell_startspan [textblock::frame -ellipsis 0 -usecache 1 -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ - # -ansibase $ansibase_header -ansiborder $ansiborder_final\ - # -boxlimits $hlims -boxmap $startmap -joins $header_joins $hval\ - # ] - - if {$this_span == 1} { - #write the actual value now - set cellcontents $hval - } else { - #just write an empty vertical placeholder. The spanned value will be overtyped below - set cellcontents [::join [lrepeat [llength [split $hval \n]] ""] \n] - } - set header_cell_startspan [textblock::frame -checkargs 0 -blockalign $col_blockalign -ellipsis 0 -usecache 1 -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ - -ansibase $ansibase_header -ansiborder $ansiborder_final\ - -boxlimits $hlims -boxmap $startmap -joins $header_joins $cellcontents\ - ] - - if {$this_span != 1} { - #puts "===>\n$header_cell_startspan\n<===" - set spanned_parts [list $header_cell_startspan] - #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 ""] - set hcell_blank [::join $h_lines \n] ;#todo - just use -height option of frame? review - currently doesn't cache with -height and no contents - slow - - - - set last [expr {[llength $remaining_spans] -1}] - set i 0 - foreach s $remaining_spans { - if {$s == 0} { - if {$i == $last} { - set next_posn right - #set next_posn inner - } else { - set next_posn inner - } - - set next_headerseps_v [tcl::dict::get $sep_elements_vertical top$next_posn] ;#static top ok - - set limj [my Get_boxlimits_and_joins $next_posn $fname_body] - set span_joins_body [tcl::dict::get $limj bodyjoins] - set span_joins [tcl::dict::get $limj joins] - set span_boxlimits [tcl::dict::get $limj boxlimits] - set span_boxlimits_top [tcl::dict::get $limj boxlimits_top] - #use struct::set instead of simple for loop - will be faster at least when critcl available - #set span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits] - #set span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits_top] - set header_span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $span_boxlimits] - set header_span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $span_boxlimits_top] - if {$hrow == 0} { - set hlims $header_span_boxlimits_top - } else { - set hlims $header_span_boxlimits - } - - set this_span_map $span_extend_map - if {!$show_seps_v} { - set hlims [struct::set difference $hlims $next_headerseps_v] - } else { - if {[llength $next_spanlist]} { - set spanbelow [lindex $next_spanlist $spancol] - if {$spanbelow != 0} { - 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 - 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 - } - } - - if {$hrow == $hmax} { - set header_joins $span_joins_body - } else { - set header_joins $span_joins - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$next_posn] ] - } - - set contentwidth [my column_width $spancol] - set header_cell [textblock::frame -ellipsis 0 -width [expr {$contentwidth + 2}] -type [tcl::dict::get $ftypes header]\ - -ansibase $ansibase_header -ansiborder $ansiborder_final\ - -boxlimits $hlims -boxmap $this_span_map -joins $header_joins $hcell_blank\ - ] - lappend spanned_parts $header_cell - } else { - break - } - incr spancol - incr i - } - - #JMN - #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 {$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 { - 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]} { - 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 - #set spacemap [list hl * vl * tlc * blc * trc * brc *] - #-usecache 1 ok - #hval is not raw headerval - it has been padded to required width and has ansi applied - set hblock [textblock::frame -checkargs 0 -ellipsis 0 -type $spacemap -boxlimits $hlims -ansibase $ansibase_header $hval] ;#review -ansibase - #puts "==>boxlimits:'$hlims' hval_width:[tcl::string::length $hval] blockwidth:[textblock::width $hblock]" - #puts $hblock - #puts "==>hval:'$hval'[a]" - #puts "==>hval:'[ansistring VIEW $hval]'" - #set spanned_frame [overtype::renderspace -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 - set spanned_frame [textblock::join_basic -- $header_cell_startspan] - } - - - append part_header $spanned_frame - append part_header \n - } else { - #zero span header directly in this column ie one that is being colspanned by some column to our left - #previous col will already have built lines for this in it's own header rhs overhang - #we need a block of TSUB chars of the right height and width in this column so that we can join this column to the left ones with the TSUBs being transparent. - - #set padwidth [my column_datawidth $cidx -headers 0 -data 1 -cached 1] - - #if there are no header elements above then we will need a minimum of the column width - #may be extended to the widest portion of the header in the loop below - set padwidth [my column_width $cidx] - - - #under assumption we are building table using L frame method and that horizontal borders are only ever 1 high - # - we can avoid using a frame - but we potentially need to manually adjust for show_hpos show_edge etc - #avoiding frame here is faster.. but not by much (<10%? on textblock::spantest2 ) - if 0 { - #breaks -show_edge 0 - if {$rowpos eq "top" && [tcl::dict::get $o_opts_table -show_edge]} { - set padheight [expr {$rowh + 2}] - } else { - set padheight [expr {$rowh + 1}] - } - set bline [tcl::string::repeat $TSUB [expr {$padwidth +1}]] - set h_lines [lrepeat $padheight $bline] - set hcell_blank [::join $h_lines \n] - set header_frame $hcell_blank - } else { - set bline [tcl::string::repeat $TSUB $padwidth] - set h_lines [lrepeat $rowh $bline] - set hcell_blank [::join $h_lines \n] - # -usecache 1 ok - #frame borders will never display - so use the simplest frametype and don't apply any ansi - #puts "===>zerospan hlims: $hlims" - set header_frame [textblock::frame -checkargs 0 -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\ - -boxlimits $hlims -boxmap $framesub_map $hcell_blank\ - ] - } - - append part_header $header_frame\n - - } - incr hrow - } - if {![llength $header_list]} { - #no headers - but we've been asked to show_header - #display a zero content-height header (ie outline if edge is being shown - or bottom bar) - set hlims $header_boxlimits_toprow - if {!$show_seps_v} { - set hlims [struct::set difference $hlims $headerseps_v] - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts only$opt_posn] ] - } - set header_joins $header_body_joins - set header_frame [textblock::frame -checkargs 0 -width [expr {$hcolwidth+2}] -type [tcl::dict::get $ftypes header]\ - -ansibase $ansibase_header -ansiborder $ansiborder_final\ - -boxlimits $hlims -boxmap $hdrmap -joins $header_joins\ - ] - append part_header $header_frame\n - } - set part_header [tcl::string::trimright $part_header \n] - lassign [textblock::size $part_header] _w return_headerwidth _h return_headerheight - - set padline [tcl::string::repeat $TSUB $return_headerwidth] - set adjusted_lines [list] - foreach ln [split $part_header \n] { - if {[tcl::string::first $TSUB $ln] >=0} { - lappend adjusted_lines $padline - } else { - lappend adjusted_lines $ln - } - } - set part_header [::join $adjusted_lines \n] - #append output $part_header \n - } - - set r 0 - set rmax [expr {[llength $cells]-1}] - - - set blims_mid $boxlimits - set blims_top $boxlimits - set blims_bot $boxlimits - set blims_top_headerless $boxlimits_headerless - set blims_only $boxlimits - set blims_only_headerless $boxlimits_headerless - if {!$show_seps_h} { - set blims_mid [struct::set difference $blims_mid $midseps_h] - set blims_top [struct::set difference $blims_top $topseps_h] - set blims_top_headerless [struct::set difference $blims_top_headerless $topseps_h] - } - if {!$show_seps_v} { - set blims_mid [struct::set difference $blims_mid $midseps_v] - set blims_top [struct::set difference $blims_top $topseps_v] - set blims_top_headerless [struct::set difference $blims_top_headerless $topseps_v] - set blims_bot [struct::set difference $blims_bot $botseps_v] - set blims_only [struct::set difference $blims_only $onlyseps_v] - set blims_only_headerless [struct::set difference $blims_only_headerless $onlyseps_v] - } - - set colidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] ;#convert possible end-1,2+2 etc expression to >= 0 integer in dict range - - set opt_col_ansibase [tcl::dict::get $o_columndefs $colidx -ansibase] ;#ordinary merge of codes already done in configure_column - #set colwidth [my column_width $colidx] - - set body_ansibase [tcl::dict::get $o_opts_table -ansibase_body] - #set ansibase [punk::ansi::codetype::sgr_merge_singles [list $body_ansibase $opt_col_ansibase]] ;#allow col to override body - set body_ansiborder [tcl::dict::get $o_opts_table -ansiborder_body] - if {[tcl::dict::get $o_opts_table -frametype] eq "block"} { - #block is the only style where bg colour can fill the frame content area exactly if the L-shaped border elements are styled - #we need to only accept background ansi codes from the columndef ansibase for this - set col_bg [punk::ansi::codetype::sgr_merge_singles [list $opt_col_ansibase] -filter_fg 1] ;#special merge for block borders - don't override fg colours - set border_ansi $body_ansibase$body_ansiborder$col_bg - } else { - set border_ansi $body_ansibase$body_ansiborder - } - - - set r 0 - set ftblock [expr {[tcl::dict::get $o_opts_table -frametype] eq "block"}] - foreach c $cells { - #cells in column - each new c is in a different row - set row_ansibase [tcl::dict::get $o_rowdefs $r -ansibase] - set row_bg "" - if {$row_ansibase ne ""} { - set row_bg [punk::ansi::codetype::sgr_merge_singles [list $row_ansibase] -filter_fg 1] - } - - set ansibase $body_ansibase$opt_col_ansibase - #todo - joinleft,joinright,joindown based on opts in args - set cell_ansibase "" - - set ansiborder_body_col_row $border_ansi$row_bg - set ansiborder_final $ansiborder_body_col_row - #$c will always have ansi resets due to overtype behaviour ? - #todo - review overtype - if {[punk::ansi::ta::detect $c]} { - #use only the last ansi sequence in the cell value - #Filter out foreground and use background for ansiborder override - set parts [punk::ansi::ta::split_codes_single $c] - #we have detected ansi - so there will always be at least 3 parts beginning and ending with pt pt,ansi,pt,ansi...,pt - set codes [list] - foreach {pt cd} $parts { - if {$cd ne ""} { - lappend codes $cd - } - } - #set takebg [lindex $parts end-1] - #set cell_bg [punk::ansi::codetype::sgr_merge_singles [list $takebg] -filter_fg 1] - set cell_bg [punk::ansi::codetype::sgr_merge_singles $codes -filter_fg 1 -filter_reset 1] - #puts --->[ansistring VIEW $codes] - - if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end]]} { - if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end-1]]} { - #special case double reset at end of content - set cell_ansi_tail [punk::ansi::codetype::sgr_merge_singles $codes] ;#no filters - set ansibase "" - set row_ansibase "" - if {$ftblock} { - set ansiborder_final [punk::ansi::codetype::sgr_merge [list $ansiborder_body_col_row] -filter_bg 1] - } - set cell_ansibase $cell_ansi_tail - } else { - #single trailing reset in content - set cell_ansibase "" ;#cell doesn't contribute to frame's ansibase - } - } else { - if {$ftblock} { - #no resets - use cell's bg to extend to the border - only for block frames - set ansiborder_final $ansiborder_body_col_row$cell_bg - } - set cell_ansibase $cell_bg - } - } - - set ansibase_final $ansibase$row_ansibase$cell_ansibase - - if {$r == 0} { - if {$r == $rmax} { - set joins [lremove $joins [lsearch $joins down*]] - set bmap $onlymap - if {$do_show_header} { - set blims $blims_only - } else { - set blims $blims_only_headerless - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts only$opt_posn] ] - } - } else { - set bmap $topmap - if {$do_show_header} { - set blims $blims_top - } else { - set blims $blims_top_headerless - } - if {![tcl::dict::get $o_opts_table -show_edge]} { - set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts top$opt_posn] ] - } - } - set rowframe [textblock::frame -checkargs 0 -type [tcl::dict::get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c] - set return_bodywidth [textblock::widthtopline $rowframe] ;#frame lines always same width - just look at top line - append part_body $rowframe \n - } else { - if {$r == $rmax} { - set joins [lremove $joins [lsearch $joins down*]] - set bmap $botmap - set blims $blims_bot - if {![tcl::dict::get $o_opts_table -show_edge]} { - set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts bottom$opt_posn] ] - } - } else { - set bmap $midmap - set blims $blims_mid ;#will only be reduced from boxlimits if -show_seps was processed above - if {![tcl::dict::get $o_opts_table -show_edge]} { - set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts middle$opt_posn] ] - } - } - append part_body [textblock::frame -checkargs 0 -type [tcl::dict::get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c]\n - } - incr r - } - #return empty (zero content height) row if no rows - if {![llength $cells]} { - set joins [lremove $joins [lsearch $joins down*]] - #we need to know the width of the column to setup the empty cell properly - #even if no header displayed - we should take account of any defined column widths - set colwidth [my column_width $index_expression] - - if {$do_show_header} { - set blims $blims_only - } else { - append part_body \n - set blims $blims_only_headerless - } - #note that if show_edge is 0 - then for this empty line - we will not expect to see any bars - #This is because the frame with no data had vertical components made entirely of corner elements - #we could just append a newline when -show_edge is zero, but we want the correct width even when empty - for proper column joins when there are colspanned headers. - # - if {![tcl::dict::get $o_opts_table -show_edge]} { - #set blims [struct::set difference $blims [tcl::dict::get $::textblock::class::table_edge_parts only$opt_posn] ] - #append output [textblock::frame -width [expr {$colwidth + 2}] -type [tcl::dict::get $ftypes body] -boxlimits $blims -boxmap $onlymap -joins $joins]\n - append part_body [tcl::string::repeat " " $colwidth] \n - set return_bodywidth $colwidth - } else { - set emptyframe [textblock::frame -checkargs 0 -width [expr {$colwidth + 2}] -type [tcl::dict::get $ftypes body] -boxlimits $blims -boxmap $onlymap -joins $joins] - append part_body $emptyframe \n - set return_bodywidth [textblock::width $emptyframe] - } - } - #assert bodywidth is integer >=0 whether there are rows or not - - #trim only 1 newline - if {[tcl::string::index $part_body end] eq "\n"} { - set part_body [tcl::string::range $part_body 0 end-1] - } - set return_bodyheight [textblock::height $part_body] - #append output $part_body - - if {$opt_return eq "string"} { - if {$part_header ne ""} { - set output $part_header - if {$part_body ne ""} { - append output \n $part_body - } - } else { - set output $part_body - } - return $output - } else { - return [tcl::dict::create header $part_header body $part_body headerwidth $return_headerwidth headerheight $return_headerheight bodywidth $return_bodywidth bodyheight $return_bodyheight] - } - } - - method get_column_cells_by_index {index_expression} { - #*** !doctools - #[call class::table [method get_column_cells_by_index] [arg index_expression]] - #[para] Return a dict with keys 'headers' and 'cells' giving column header and data values - - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - set range "" - if {[tcl::dict::size $o_columndefs] > 0} { - set range "0..[expr {[tcl::dict::size $o_columndefs] -1}]" - } else { - set range empty - } - 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 ansibase_col [tcl::dict::get $cdef -ansibase] - set textalign [tcl::dict::get $cdef -textalign] - switch -- $textalign { - left {set pad right} - right {set pad left} - default { - set pad "centre" ;#todo? - } - } - - #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] - #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 output [tcl::dict::create] - tcl::dict::set output headers [list] - - set showing_vseps [my Showing_vseps] - for {set hrow 0} {$hrow < $num_header_rows} {incr hrow} { - set hdr [lindex $headerlist $hrow] - #jjj - set header_maxdataheight [tcl::dict::get $o_headerstates $hrow maxheightseen] - #set header_maxdataheight [my header_height $hrow] ;#from cached headerstates - set headerdefminh [tcl::dict::get $o_headerdefs $hrow -minheight] - set headerdefmaxh [tcl::dict::get $o_headerdefs $hrow -maxheight] - if {"$headerdefminh$headerdefmaxh" ne "" && $headerdefminh eq $headerdefmaxh} { - set headerh $headerdefminh ;#exact height defined for the row - } else { - if {$headerdefminh eq ""} { - if {$headerdefmaxh eq ""} { - #both defs empty - set headerh $header_maxdataheight - } else { - set headerh [expr {min(1,$headerdefmaxh,$header_maxdataheight)}] - } - } else { - if {$headerdefmaxh eq ""} { - set headerh [expr {max($headerdefminh,$header_maxdataheight)}] - } else { - if {$header_maxdataheight < $headerdefminh} { - set headerh $headerdefminh - } else { - set headerh [expr {max($headerdefminh,$header_maxdataheight)}] - } - } - } - } - - - set headerrow_colspans [tcl::dict::get $all_colspans $hrow] - 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 -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] - set hval_lines [split $hdr \n] - #jmn concat - #set hval_lines [concat $hval_lines $hcell_lines] - set hval_lines [list {*}$hval_lines {*}$hcell_lines] - set hval_lines [lrange $hval_lines 0 $header_maxdataheight-1] ;#vertical align top - set hval_block [::join $hval_lines \n] - set hcell [textblock::pad $hval_block -width $this_hdrwidth -padchar " " -within_ansi 1 -which $pad] - tcl::dict::lappend output headers $hcell - } - - - #set colwidth [my column_width $cidx] - #set cell_line_blank [tcl::string::repeat " " $colwidth] - set datawidth [my column_datawidth $cidx -headers 0 -footers 0 -data 1 -cached 1] - set cell_line_blank [tcl::string::repeat " " $datawidth] - - - - set items [tcl::dict::get $o_columndata $cidx] - #puts "---> columndata $o_columndata" - - #set opt_row_ansibase [tcl::dict::get $o_rowdefs $r -ansibase] - #set cell_ansibase $ansibase_body$ansibase_col$opt_row_ansibase - - tcl::dict::set output cells [list];#ensure we return something for cells key if no items in list - set r 0 - foreach cval $items { - #todo move to row_height method ? - set maxdataheight [tcl::dict::get $o_rowstates $r -maxheight] - set rowdefminh [tcl::dict::get $o_rowdefs $r -minheight] - set rowdefmaxh [tcl::dict::get $o_rowdefs $r -maxheight] - if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} { - set rowh $rowdefminh ;#an exact height is defined for the row - } else { - if {$rowdefminh eq ""} { - if {$rowdefmaxh eq ""} { - #both defs empty - set rowh $maxdataheight - } else { - set rowh [expr {min(1,$rowdefmaxh,$maxdataheight)}] - } - } else { - if {$rowdefmaxh eq ""} { - set rowh [expr {max($rowdefminh,$maxdataheight)}] - } else { - if {$maxdataheight < $rowdefminh} { - set rowh $rowdefminh - } else { - set rowh [expr {max($rowdefminh,$maxdataheight)}] - } - } - } - } - - set cell_lines [lrepeat $rowh $cell_line_blank] - #set cell_blank [join $cell_lines \n] - - - set cval_lines [split $cval \n] - #jmn - #set cval_lines [concat $cval_lines $cell_lines] - lappend cval_lines {*}$cell_lines - set cval_lines [lrange $cval_lines 0 $rowh-1] - set cval_block [::join $cval_lines \n] - - #//JMN assert widest cval_line = datawidth = known_blockwidth - set cell [textblock::pad $cval_block -known_blockwidth $datawidth -width $datawidth -padchar " " -within_ansi 1 -which $pad] - #set cell [textblock::pad $cval_block -width $colwidth -padchar " " -within_ansi 0 -which left] - tcl::dict::lappend output cells $cell - - incr r - } - return $output - } - method get_column_values_by_index {index_expression} { - #*** !doctools - #[call class::table [method get_column_values_by_index] [arg index_expression]] - #[para] List the cell values of a column from the data area only (no header values) - - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - return - } - return [tcl::dict::get $o_columndata $cidx] - } - method debug {args} { - #*** !doctools - #[call class::table [method debug]] - #[para] display lots of debug information about how the table is constructed. - - #nice to lay this out with tables - but this is the one function where we really should provide the ability to avoid tables in case things get really broken (e.g major refactor) - set defaults [tcl::dict::create\ - -usetables 1\ - ] - foreach {k v} $args { - switch -- $k { - -usetables {} - default { - error "table debug unrecognised option '$k'. Known options: [tcl::dict::keys $defaults]" - } - } - } - set opts [tcl::dict::merge $defaults $args] - set opt_usetables [tcl::dict::get $opts -usetables] - - puts stdout "rowdefs: $o_rowdefs" - puts stdout "rowstates: $o_rowstates" - #puts stdout "columndefs: $o_columndefs" - puts stdout "columndefs:" - if {!$opt_usetables} { - tcl::dict::for {k v} $o_columndefs { - puts " $k $v" - } - } else { - set t [textblock::class::table new] - $t add_column -headers "Col" - tcl::dict::for {col coldef} $o_columndefs { - foreach property [tcl::dict::keys $coldef] { - if {$property eq "-ansireset"} { - continue - } - $t add_column -headers $property - } - break - } - - #build our inner tables first so we can sync widths - set col_header_tables [tcl::dict::create] - set max_widths [tcl::dict::create 0 0 1 0 2 0 3 0] ;#max inner table column widths - tcl::dict::for {col coldef} $o_columndefs { - set row [list $col] - set colheaders [tcl::dict::get $coldef -headers] - #inner table probably overkill here ..but just as easy - set htable [textblock::class::table new] - $htable configure -show_header 1 -show_edge 0 -show_hseps 0 - $htable add_column -headers row - $htable add_column -headers text - $htable add_column -headers WxH - $htable add_column -headers span - set hnum 0 - set spans [tcl::dict::get $o_columndefs $col -header_colspans] - foreach h $colheaders s $spans { - lassign [textblock::size $h] _w width _h height - $htable add_row [list "$hnum " $h "${width}x${height}" $s] - incr hnum - } - $htable configure_column 0 -ansibase [a+ web-dimgray] - tcl::dict::set col_header_tables $col $htable - set colwidths [$htable column_widths] - set icol 0 - foreach w $colwidths { - if {$w > [tcl::dict::get $max_widths $icol]} { - tcl::dict::set max_widths $icol $w - } - incr icol - } - } - - #safe jumptable test - #dict for {col coldef} $o_columndefs {} - tcl::dict::for {col coldef} $o_columndefs { - set row [list $col] - #safe jumptable test - #dict for {property val} $coldef {} - tcl::dict::for {property val} $coldef { - switch -- $property { - -ansireset {continue} - -headers { - set htable [tcl::dict::get $col_header_tables $col] - tcl::dict::for {innercol maxw} $max_widths { - $htable configure_column $innercol -minwidth $maxw -blockalign left - } - lappend row [$htable print] - $htable destroy - } - default { - lappend row $val - } - } - } - $t add_row $row - } - - - - - $t configure -show_header 1 - puts stdout [$t print] - $t destroy - } - puts stdout "columnstates: $o_columnstates" - puts stdout "headerdefs: $o_headerdefs" - puts stdout "headerstates: $o_headerstates" - tcl::dict::for {k coldef} $o_columndefs { - if {[tcl::dict::exists $o_columndata $k]} { - set headerlist [tcl::dict::get $coldef -headers] - set coldata [tcl::dict::get $o_columndata $k] - set colinfo "rowcount: [llength $coldata]" - set allfields [concat $headerlist $coldata] - if {[llength $allfields]} { - set widest [tcl::mathfunc::max {*}[lmap v $allfields {textblock::width $v}]] - } else { - set widest 0 - } - append colinfo " widest of headers and data: $widest" - } else { - set colinfo "WARNING - no columndata record for column key '$k'" - } - puts stdout "column $k columndata info: $colinfo" - } - set result "" - set cols [list] - set max [expr {[tcl::dict::size $o_columndefs]-1}] - foreach c [tcl::dict::keys $o_columndefs] { - if {$c == 0} { - lappend cols [my get_column_by_index $c -position left] " " - } elseif {$c == $max} { - lappend cols [my get_column_by_index $c -position right] - } else { - lappend cols [my get_column_by_index $c -position inner] " " - } - } - append result [textblock::join -- {*}$cols] - return $result - } - #column width including headers - but without colspan consideration - method column_width_configured {index_expression} { - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - return - } - #assert cidx is now >=0 integer within the range of defined columns - set cdef [tcl::dict::get $o_columndefs $cidx] - set defminw [tcl::dict::get $cdef -minwidth] - set defmaxw [tcl::dict::get $cdef -maxwidth] - if {"$defminw$defmaxw" ne "" && $defminw eq $defmaxw} { - #an exact width is defined for the column - no need to look at data width - set colwidth $defminw - } else { - #set widest [my column_datawidth $cidx -headers 1 -data 1 -footers 1] - set hwidest [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] - #set hwidest [my column_datawidth $cidx -headers 1 -colspan 1 -data 0 -footers 1] - #set hwidest_singlespan ?? - set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] - set widest [expr {max($hwidest,$bwidest)}] - #todo - predetermine if any items in column contain newlines and are truncated vertically due to o_rowdefs configuration. - #if so - a truncated line shouldn't be included in our width calculation - if {$defminw eq ""} { - if {$defmaxw eq ""} { - set colwidth $widest - } else { - set colwidth [expr {min($defmaxw,$widest)}] - } - } else { - if {$defmaxw eq ""} { - set colwidth [expr {max($defminw,$widest)}] - } else { - if {$widest < $defminw} { - set colwidth $defminw - } else { - if {$widest > $defmaxw} { - set colwidth $defmaxw - } else { - set colwidth [expr {max($defminw,$widest)}] - } - } - } - } - } - return $colwidth - } - - method column_width {index_expression} { - #*** !doctools - #[call class::table [method column_width] [arg index_expression]] - #[para] inner width of column ie the available cell-width without borders/separators - - if {[llength $o_calculated_column_widths] != [tcl::dict::size $o_columndefs]} { - my calculate_column_widths -algorithm $o_column_width_algorithm - } - return [lindex $o_calculated_column_widths $index_expression] - } - method column_widths {} { - #*** !doctools - #[call class::table [method column_width]] - #[para] ordered list of column widths (inner widths) - - if {[llength $o_calculated_column_widths] != [tcl::dict::size $o_columndefs]} { - my calculate_column_widths -algorithm $o_column_width_algorithm - } - return $o_calculated_column_widths - } - - #width of a table includes borders and seps - #whereas width of a column refers to the borderless width (inner width) - method width {} { - #*** !doctools - #[call class::table [method width]] - #[para] width of the table including borders and separators - #[para] calculate width based on assumption frame verticals are 1 screen-column wide - #[para] (review - consider possibility of custom unicode double-wide frame?) - - set colwidths [my column_widths] - set contentwidth [tcl::mathop::+ {*}$colwidths] - set twidth $contentwidth - if {[my Showing_vseps]} { - incr twidth [llength $colwidths] - incr twidth -1 - } - if {[tcl::dict::get $o_opts_table -show_edge]} { - incr twidth 2 - } - return $twidth - } - - #column *body* content width - method basic_column_width {index_expression} { - set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] - if {$cidx eq ""} { - return - } - #puts "===column_width $index_expression" - #assert cidx is now >=0 integer within the range of defined columns - set cdef [tcl::dict::get $o_columndefs $cidx] - set defminw [tcl::dict::get $cdef -minwidth] - set defmaxw [tcl::dict::get $cdef -maxwidth] - if {"$defminw$defmaxw" ne "" && $defminw eq $defmaxw} { - #an exact width is defined for the column - no need to look at data width - #review - this can result in truncation of spanning headers - even though there is enough width in the span-cell to place the full header - set colwidth $defminw - } else { - #set widest [my column_datawidth $cidx -headers 0 -data 1 -footers 0] - set widest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] - #todo - predetermine if any items in column contain newlines and are truncated vertically due to o_rowdefs configuration. - #if so - a truncated line shouldn't be included in our width calculation - if {$defminw eq ""} { - if {$defmaxw eq ""} { - set colwidth $widest - } else { - set colwidth [expr {min($defmaxw,$widest)}] - } - } else { - if {$defmaxw eq ""} { - set colwidth [expr {max($defminw,$widest)}] - } else { - if {$widest < $defminw} { - set colwidth $defminw - } else { - if {$widest > $defmaxw} { - set colwidth $defmaxw - } else { - set colwidth [expr {max($defminw,$widest)}] - } - } - } - } - } - set configured_widths [list] - foreach c [tcl::dict::keys $o_columndefs] { - lappend configured_widths [my column_width_configured $c] - } - set header_colspans [my header_colspans] - set width_max $colwidth - set test_width $colwidth - set showing_vseps [my Showing_vseps] - set thiscol_widest_header [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] - tcl::dict::for {h colspans} $header_colspans { - set spanc [lindex $colspans $cidx] - #set headers [tcl::dict::get $cdef -headers] - #set thiscol_widest_header 0 - #if {[llength $headers] > 0} { - # set thiscol_widest_header [tcl::mathfunc::max {*}[lmap v $headers {textblock::width $v}]] - #} - if {$spanc eq "1"} { - if {$thiscol_widest_header > $colwidth} { - set test_width [expr {max($thiscol_widest_header,$colwidth)}] - if {$defmaxw ne ""} { - set test_width [expr {min($colwidth,$defmaxw)}] - } - } - set width_max [expr {max($test_width,$width_max)}] - continue - } - 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] - while {$spanlength eq "0" && $cnext < [llength $colspans]} { - lappend spanned $cnext - incr cnext - set spanlength [lindex $colspans $cnext] - } - set others_width 0 - foreach col $spanned { - incr others_width [lindex $configured_widths $col] - if {$showing_vseps} { - incr others_width 1 - } - } - set total_spanned_width [expr {$width_max + $others_width}] - if {$thiscol_widest_header > $total_spanned_width} { - #this just allocates the extra space in the current column - which is not great. - #A proper algorithm for distributing width created by headers to all the spanned columns is needed. - #This is a tricky problem with multiple header lines and arbitrary spans. - #The calculation should probably be done on the table as a whole first and this function should just look up that result. - #Trying to calculate on a specific column only is unlikely to be easy or efficient. - set needed [expr {$thiscol_widest_header - $total_spanned_width}] - #puts "-->>col $cidx needed ($thiscol_widest_header - $total_spanned_width): $needed (spanned $spanned)" - if {$defmaxw ne ""} { - set test_width [expr {min($colwidth+$needed,$defmaxw)}] - } else { - set test_width [expr {$colwidth + $needed}] - } - } - } - set width_max [expr {max($test_width,$width_max)}] - } - - #alternative to all the above shennanigans.. let the body cell data determine the size and just wrap the headers - #could also split the needed width amongst the spanned columns? configurable for whether cells expand? - set expand_first_column 1 - if {$expand_first_column} { - set colwidth $width_max - } - - #puts "---column_width $cidx = $colwidth" - return $colwidth - } - method Showing_vseps {} { - #review - show_seps and override mechanism for show_vseps show_hseps - document. - set seps [tcl::dict::get $o_opts_table -show_seps] - set vseps [tcl::dict::get $o_opts_table -show_vseps] - if {$seps eq ""} { - if {$vseps eq "" || $vseps} { - return true - } - } elseif {$seps} { - if {$vseps eq "" || $vseps} { - return true - } - } else { - if {$vseps ne "" && $vseps} { - return true - } - } - return false - } - - method column_datawidth {index_expression args} { - set opts [tcl::dict::create\ - -headers 0\ - -footers 0\ - -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 { - -headers - -footers - -colspan - -data - -cached { - tcl::dict::set opts $k $v - } - default { - error "column_datawidth unrecognised flag '$k'. Known flags: [tcl::dict::keys $opts]" - } - } - } - 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] - if {$cidx eq ""} { - return - } - - if {[tcl::dict::get $opts -cached]} { - set hwidest 0 - set bwidest 0 - set fwidest 0 - if {[tcl::dict::get $opts -headers]} { - 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_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]} { - set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthbodyseen] - } - if {[tcl::dict::get $opts -footers]} { - #TODO! - #set bwidest [tcl::dict::get $o_columnstates $cidx maxwidthfooterseen] - } - return [expr {max($hwidest,$bwidest,$fwidest)}] - } - - #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]} { - 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]} { - lappend values {*}[tcl::dict::get $o_columndata $cidx] - } - } - if {[tcl::dict::get $opts -footers]} { - lappend values {*}[tcl::dict::get $o_columndefs $cidx -footers] - } - if {[llength $values]} { - set valwidest [tcl::mathfunc::max {*}[lmap v $values {textblock::width $v}]] - set widest [expr {max($valwidest,$hwidest)}] - } else { - set widest $hwidest - } - return $widest - } - #print1 uses basic column joining - useful for testing/debug especially with colspans - method print1 {args} { - if {![llength $args]} { - set cols [tcl::dict::keys $o_columndata] - } else { - set cols [list] - foreach colspec $args { - set allcols [tcl::dict::keys $o_columndata] - if {[tcl::string::first .. $colspec] >=0} { - set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] - if {[llength $parts] != 3} { - error "[namespace::current]::table error invalid print specification '$colspec'" - } - lassign $parts from _dd to - if {$from eq ""} {set from 0 } - if {$to eq ""} {set to end} - - set indices [lrange $allcols $from $to] - lappend cols {*}$indices - } else { - set c [lindex $allcols $colspec] - if {$c ne ""} { - lappend cols $c - } - } - } - } - set blocks [list] - set colposn 0 - set numposns [llength $cols] - foreach c $cols { - set flags [list] - if {$colposn == 0 && $colposn == $numposns-1} { - set flags [list -position solo] - } elseif {$colposn == 0} { - set flags [list -position left] - } elseif {$colposn == $numposns-1} { - set flags [list -position right] - } else { - set flags [list -position inner] - } - lappend blocks [my get_column_by_index $c {*}$flags] - incr colposn - } - if {[llength $blocks]} { - return [textblock::join -- {*}$blocks] - } else { - return "No columns matched" - } - } - method columncalc_spans {allocmethod} { - set colwidths [tcl::dict::create] ;# to use tcl::dict::incr - set colspace_added [tcl::dict::create] - - set ordered_spans [tcl::dict::create] - tcl::dict::for {col spandata} [my spangroups] { - set dwidth [my column_datawidth $col -data 1 -headers 0 -footers 0 -cached 1] - set minwidth [tcl::dict::get $o_columndefs $col -minwidth] - set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth] - if {$minwidth ne ""} { - if {$dwidth < $minwidth} { - set dwidth $minwidth - } - } - if {$maxwidth ne ""} { - if {$dwidth > $maxwidth} { - set dwidth $maxwidth - } - } - tcl::dict::set colwidths $col $dwidth ;#spangroups is ordered by column - so colwidths dict will be correctly ordered - tcl::dict::set colspace_added $col 0 - - set spanlengths [tcl::dict::get $spandata spanlengths] - foreach slen $spanlengths { - set spans [tcl::dict::get $spandata spangroups $slen] - set spans [lsort -index 7 -integer $spans] - foreach s $spans { - set hwidth [tcl::dict::get $s headerwidth] - set hrow [tcl::dict::get $s hrow] - set scol [tcl::dict::get $s startcol] - tcl::dict::set ordered_spans $scol,$hrow membercols $col $dwidth - tcl::dict::set ordered_spans $scol,$hrow headerwidth $hwidth - } - } - } - - #safe jumptable test - #dict for {spanid spandata} $ordered_spans {} - tcl::dict::for {spanid spandata} $ordered_spans { - lassign [split $spanid ,] startcol hrow - set memcols [tcl::dict::get $spandata membercols] ;#dict with col and initial width - we ignore initial width, it's there in case we want to allocate space based on initial data width ratios - set colids [tcl::dict::keys $memcols] - set hwidth [tcl::dict::get $spandata headerwidth] - set num_cols_spanned [tcl::dict::size $memcols] - if {$num_cols_spanned == 1} { - set col [lindex $memcols 0] - set space_to_alloc [expr {$hwidth - [tcl::dict::get $colwidths $col]}] - if {$space_to_alloc > 0} { - set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth] - if {$maxwidth ne ""} { - if {$maxwidth > [tcl::dict::get $colwidths $col]} { - set can_alloc [expr {$maxwidth - [tcl::dict::get $colwidths $col]}] - } else { - set can_alloc 0 - } - set will_alloc [expr {min($space_to_alloc,$can_alloc)}] - } else { - set will_alloc $space_to_alloc - } - if {$will_alloc} { - #tcl::dict::set colwidths $col $hwidth - tcl::dict::incr colwidths $col $will_alloc - tcl::dict::set colspace_added $col $will_alloc - } - #log! - #if {$will_alloc < $space_to_alloc} { - # #todo - debug only - # puts stderr "max width $maxwidth hit for col $col - cannot allocate extra [expr {$space_to_alloc - $will_alloc}]" - #} - } - } elseif {$num_cols_spanned > 1} { - set spannedwidth 0 - foreach col $colids { - incr spannedwidth [tcl::dict::get $colwidths $col] - } - set space_to_alloc [expr {$hwidth - $spannedwidth}] - if {[my Showing_vseps]} { - set sepcount [expr {$num_cols_spanned -1}] - incr space_to_alloc -$sepcount - } - #review - we want to reduce overallocation to earlier or later columns - hence the use of colspace_added - switch -- $allocmethod { - least { - #add to least-expanded each time - #safer than method 1 - pretty balanced - if {$space_to_alloc > 0} { - for {set i 0} {$i < $space_to_alloc} {incr i} { - set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] - set ordered_all_colids [tcl::dict::keys $ordered_colspace_added] - foreach testcolid $ordered_all_colids { - if {$testcolid in $colids} { - #assert - we will always find a match - set colid $testcolid - break - } - } - tcl::dict::incr colwidths $colid - tcl::dict::incr colspace_added $colid - } - } - } - least_unmaxed { - #TODO - fix header truncation/overflow issues when they are restricted by column maxwidth - #(we should be able to collapse column width to zero and have header colspans gracefully respond) - #add to least-expanded each time - #safer than method 1 - pretty balanced - if {$space_to_alloc > 0} { - for {set i 0} {$i < $space_to_alloc} {incr i} { - set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] - set ordered_all_colids [tcl::dict::keys $ordered_colspace_added] - set colid "" - foreach testcolid $ordered_all_colids { - set maxwidth [tcl::dict::get $o_columndefs $testcolid -maxwidth] - set can_alloc [expr {$maxwidth eq "" || $maxwidth > [tcl::dict::get $colwidths $testcolid]}] - if {$testcolid in $colids} { - if {$can_alloc} { - set colid $testcolid - break - } else { - #remove from future consideration in for loop - #log! - #puts stderr "max width $maxwidth hit for col $testcolid" - tcl::dict::unset colspace_added $testcolid - } - } - } - if {$colid ne ""} { - tcl::dict::incr colwidths $colid - tcl::dict::incr colspace_added $colid - } - } - } - } - all { - #adds space to all columns - not just those spanned - risk of underallocating and truncating some headers! - #probably not a good idea for tables with complex headers and spans - while {$space_to_alloc > 0} { - set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] - set ordered_colids [tcl::dict::keys $ordered_colspace_added] - - foreach col $ordered_colids { - tcl::dict::incr colwidths $col - tcl::dict::incr colspace_added $col - incr space_to_alloc -1 - if {$space_to_alloc == 0} { - break - } - } - } - - } - } - } - } - - set column_widths [tcl::dict::values $colwidths] - #todo - -maxwidth etc - set table_minwidth [tcl::dict::get $o_opts_table -minwidth] ;#min width including frame elements - if {[tcl::string::is integer -strict $table_minwidth]} { - set contentwidth [tcl::mathop::+ {*}$column_widths] - set twidth $contentwidth - if {[my Showing_vseps]} { - incr twidth [llength $column_widths] - incr twidth -1 - } - if {[tcl::dict::get $o_opts_table -show_edge]} { - incr twidth 2 - } - # - set shortfall [expr {$table_minwidth - $twidth}] - if {$shortfall > 0} { - set space_to_alloc $shortfall - while {$space_to_alloc > 0} { - set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] - set ordered_colids [tcl::dict::keys $ordered_colspace_added] - - foreach col $ordered_colids { - tcl::dict::incr colwidths $col - tcl::dict::incr colspace_added $col - incr space_to_alloc -1 - if {$space_to_alloc == 0} { - break - } - } - } - set column_widths [tcl::dict::values $colwidths] - } - - } - - return [list ordered_spans $ordered_spans colwidths $column_widths adjustments $colspace_added] - } - - #spangroups keyed by column - method spangroups {} { - #*** !doctools - #[call class::table [method spangroups]] - #[para] return a dict keyed by column-index showing advanced span information - #[para] (debug tool) - - set column_count [tcl::dict::size $o_columndefs] - set spangroups [tcl::dict::create] - set headerwidths [tcl::dict::create] ;#key on col,hrow - foreach c [tcl::dict::keys $o_columndefs] { - tcl::dict::set spangroups $c [list spanlengths {}] - set spanlist [my column_get_spaninfo $c] - set index_spanlen_val 5 - set spanlist [lsort -index $index_spanlen_val -integer $spanlist] - set ungrouped $spanlist - - while {[llength $ungrouped]} { - set spanlen [lindex $ungrouped 0 $index_spanlen_val] - set spangroup_posns [lsearch -all -index $index_spanlen_val $ungrouped $spanlen] - set sgroup [list] - foreach p $spangroup_posns { - set spaninfo [lindex $ungrouped $p] - set hcol [tcl::dict::get $spaninfo startcol] - set hrow [tcl::dict::get $spaninfo hrow] - set header [lindex [tcl::dict::get $o_columndefs $hcol -headers] $hrow] - if {[tcl::dict::exists $headerwidths $hcol,$hrow]} { - set hwidth [tcl::dict::get $headerwidths $hcol,$hrow] - } else { - set hwidth [textblock::width $header] - tcl::dict::set headerwidths $hcol,$hrow $hwidth - } - lappend spaninfo headerwidth $hwidth - lappend sgroup $spaninfo - } - set spanlengths [tcl::dict::get $spangroups $c spanlengths] - lappend spanlengths $spanlen - tcl::dict::set spangroups $c spanlengths $spanlengths - tcl::dict::set spangroups $c spangroups $spanlen $sgroup - set ungrouped [lremove $ungrouped {*}$spangroup_posns] - } - } - return $spangroups - } - method column_get_own_spans {cidx} { - set colspans_for_column [tcl::dict::get $o_columndefs $cidx -header_colspans] - } - method column_get_spaninfo {cidx} { - set spans_by_header [my header_colspans] - set colspans_for_column [tcl::dict::get $o_columndefs $cidx -header_colspans] - set spaninfo [list] - set numcols [tcl::dict::size $o_columndefs] - #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 "any" || $thiscol_spanval > 0} { - set spanstartcol $cidx ;#own column - 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 any or a non-zero value - for {set i $cidx} {$i > -1} {incr i -1} { - set s [lindex $rawspans $i] - if {$s eq "any" || $s > 0} { - set spanstartcol $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 - } - break - } - } - } - #assert - we should always find 1 answer for each header row - lappend spaninfo [list hrow $hrow startcol $spanstartcol spanlen $spanlen] - } - return $spaninfo - } - method calculate_column_widths {args} { - set column_count [tcl::dict::size $o_columndefs] - - set opts [tcl::dict::create\ - -algorithm $o_column_width_algorithm\ - ] - foreach {k v} $args { - switch -- $k { - -algorithm { - tcl::dict::set opts $k $v - } - default { - error "Unknown option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - set opt_algorithm [tcl::dict::get $opts -algorithm] - #puts stderr "--- recalculating column widths -algorithm $opt_algorithm" - set known_algorithms [list basic simplistic span span2] - switch -- $opt_algorithm { - basic { - #basic column by column - This allocates extra space to first span/column as they're encountered. - #This can leave the table quite unbalanced with regards to whitespace and the table is also not as compact as it could be especially with regards to header colspans - #The header values can extend over some of the spanned columns - but not optimally so. - set o_calculated_column_widths [list] - for {set c 0} {$c < $column_count} {incr c} { - lappend o_calculated_column_widths [my basic_column_width $c] - } - } - simplistic { - #just uses the widest column data or header element. - #this is even less compact than basic and doesn't allow header colspan values to extend beyond their first spanned column - #This is a conservative option potentially useful in testing/debugging. - set o_calculated_column_widths [list] - for {set c 0} {$c < $column_count} {incr c} { - lappend o_calculated_column_widths [my column_width_configured $c] - } - } - span { - #widest of smallest spans first method - #set calcresult [my columncalc_spans least] - set calcresult [my columncalc_spans least_unmaxed] - set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] - } - span2 { - #allocates more evenly - but truncates headers sometimes - set calcresult [my columncalc_spans all] - set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] - } - default { - error "calculate_column_widths unknown algorithm $opt_algorithm. Known algorithms: $known_algorithms" - } - } - #remember the last algorithm used - set o_column_width_algorithm $opt_algorithm - return $o_calculated_column_widths - } - method print2 {args} { - variable full_column_cache - set full_column_cache [tcl::dict::create] - - if {![llength $args]} { - set cols [tcl::dict::keys $o_columndata] - } else { - set cols [list] - foreach colspec $args { - set allcols [tcl::dict::keys $o_columndata] - if {[tcl::string::first .. $colspec] >=0} { - set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] - if {[llength $parts] != 3} { - error "[namespace::current]::table error invalid print specification '$colspec'" - } - lassign $parts from _dd to - if {$from eq ""} {set from 0} - if {$to eq ""} {set to end} - - set indices [lrange $allcols $from $to] - lappend cols {*}$indices - } else { - set c [lindex $allcols $colspec] - if {$c ne ""} { - lappend cols $c - } - } - } - } - set blocks [list] - set colposn 0 - set numposns [llength $cols] - set padwidth 0 - set table "" - foreach c $cols { - set flags [list] - if {$colposn == 0 && $colposn == $numposns-1} { - set flags [list -position solo] - } elseif {$colposn == 0} { - set flags [list -position left] - } elseif {$colposn == $numposns-1} { - set flags [list -position right] - } else { - set flags [list -position inner] - } - #lappend blocks [my get_column_by_index $c {*}$flags] - #todo - only check and store in cache if table has header or footer colspans > 1 - if {[tcl::dict::exists $full_column_cache $c]} { - #puts "!!print used full_column_cache for $c" - set columninfo [tcl::dict::get $full_column_cache $c] - } else { - set columninfo [my get_column_by_index $c -return dict {*}$flags] - tcl::dict::set full_column_cache $c $columninfo - } - set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] - set bodywidth [tcl::dict::get $columninfo bodywidth] - - if {$table eq ""} { - set table $nextcol - set height [textblock::height $table] ;#only need to get height once at start - } else { - set nextcol [textblock::join -- [textblock::block $padwidth $height $TSUB] $nextcol] - set table [overtype::renderspace -expand_right 1 -transparent $TSUB $table[unset table] $nextcol] - #JMN - - #set nextcol [textblock::join -- [textblock::block $padwidth $height "\uFFFF"] $nextcol] - #set table [overtype::renderspace -expand_right 1 -transparent \uFFFF $table $nextcol] - } - incr padwidth $bodywidth - incr colposn - } - - if {[llength $cols]} { - #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? - set titlepad [tcl::string::repeat $TSUB $offset] - if {[tcl::dict::get $o_opts_table -title] ne ""} { - set titlealign [tcl::dict::get $o_opts_table -titlealign] - switch -- $titlealign { - left { - set tstring $titlepad[tcl::dict::get $o_opts_table -title] - } - right { - set tstring [tcl::dict::get $o_opts_table -title]$titlepad - } - default { - set tstring [tcl::dict::get $o_opts_table -title] - } - } - set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] - switch -- $opt_titletransparent { - 0 { - set mapchar "" - } - 1 { - set mapchar " " - } - default { - #won't work if not a single char - review - check also frame behaviour - set mapchar $opt_titletransparent - } - } - if {$mapchar ne ""} { - set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] - } - set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] - } - } - return $table - } else { - return "No columns matched" - } - } - - # using -startcolumn to do slightly less work - method print3 {args} { - if {![llength $args]} { - set cols [tcl::dict::keys $o_columndata] - } else { - set cols [list] - foreach colspec $args { - set allcols [tcl::dict::keys $o_columndata] - if {[tcl::string::first .. $colspec] >=0} { - set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] - if {[llength $parts] != 3} { - error "[namespace::current]::table error invalid print specification '$colspec'" - } - lassign $parts from _dd to - if {$from eq ""} {set from 0} - if {$to eq ""} {set to end} - - set indices [lrange $allcols $from $to] - lappend cols {*}$indices - } else { - set c [lindex $allcols $colspec] - if {$c ne ""} { - lappend cols $c - } - } - } - } - set blocks [list] - set numposns [llength $cols] - set colposn 0 - set padwidth 0 - set table "" - foreach c $cols { - set flags [list] - if {$colposn == 0 && $colposn == $numposns-1} { - set flags [list -position solo] - } elseif {$colposn == 0} { - set flags [list -position left] - } elseif {$colposn == $numposns-1} { - set flags [list -position right] - } else { - set flags [list -position inner] - } - set columninfo [my get_column_by_index $c -return dict {*}$flags] - set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] - set bodywidth [tcl::dict::get $columninfo bodywidth] - - if {$table eq ""} { - set table $nextcol - set height [textblock::height $table] ;#only need to get height once at start - } else { - set table [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $table $nextcol] - } - incr padwidth $bodywidth - incr colposn - } - - if {[llength $cols]} { - #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? - set titlepad [tcl::string::repeat $TSUB $offset] - if {[tcl::dict::get $o_opts_table -title] ne ""} { - set titlealign [tcl::dict::get $o_opts_table -titlealign] - switch -- $titlealign { - left { - set tstring $titlepad[tcl::dict::get $o_opts_table -title] - } - right { - set tstring [tcl::dict::get $o_opts_table -title]$titlepad - } - default { - set tstring [tcl::dict::get $o_opts_table -title] - } - } - set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] - switch -- $opt_titletransparent { - 0 { - set mapchar "" - } - 1 { - set mapchar " " - } - default { - #won't work if not a single char - review - check also frame behaviour - set mapchar $opt_titletransparent - } - } - if {$mapchar ne ""} { - set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] - } - set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] - } - } - return $table - } else { - return "No columns matched" - } - } - - #print headers and body using different join mechanisms - # using -startcolumn to do slightly less work - method print {args} { - #*** !doctools - #[call class::table [method print]] - #[para] Return the table as text suitable for console display - - if {![llength $args]} { - set cols [tcl::dict::keys $o_columndata] - } else { - set cols [list] - foreach colspec $args { - set allcols [tcl::dict::keys $o_columndata] - if {[tcl::string::first .. $colspec] >=0} { - set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec] - if {[llength $parts] != 3} { - error "[namespace::current]::table error invalid print specification '$colspec'" - } - lassign $parts from _dd to - if {$from eq ""} {set from 0} - if {$to eq ""} {set to end} - - set indices [lrange $allcols $from $to] - lappend cols {*}$indices - } else { - set c [lindex $allcols $colspec] - if {$c ne ""} { - lappend cols $c - } - } - } - } - set numposns [llength $cols] - set colposn 0 - set padwidth 0 - set header_build "" - set body_blocks [list] - set headerheight 0 - foreach c $cols { - set flags [list] - if {$colposn == 0 && $colposn == $numposns-1} { - set flags [list -position solo] - } elseif {$colposn == 0} { - set flags [list -position left] - } elseif {$colposn == $numposns-1} { - set flags [list -position right] - } else { - set flags [list -position inner] - } - set columninfo [my get_column_by_index $c -return dict {*}$flags] - #set nextcol [tcl::dict::get $columninfo column] - set bodywidth [tcl::dict::get $columninfo bodywidth] - set headerheight [tcl::dict::get $columninfo headerheight] - #set nextcol_lines [split $nextcol \n] - #set nextcol_header [join [lrange $nextcol_lines 0 $headerheight-1] \n] - #set nextcol_body [join [lrange $nextcol_lines $headerheight end] \n] - set nextcol_header [tcl::dict::get $columninfo header] - set nextcol_body [tcl::dict::get $columninfo body] - - if {$header_build eq "" && ![llength $body_blocks]} { - set header_build $nextcol_header - } else { - if {$headerheight > 0} { - set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]] - } - #set body_build [textblock::join -- $body_build[unset body_build] $nextcol_body] - } - lappend body_blocks $nextcol_body - incr padwidth $bodywidth - incr colposn - } - if {![llength $body_blocks]} { - set body_build "" - } else { - #body blocks should not be ragged - so can use join_basic - set body_build [textblock::join_basic -- {*}$body_blocks] - } - if {$headerheight > 0} { - set table [tcl::string::cat $header_build \n $body_build] - } else { - set table $body_build - } - - if {[llength $cols]} { - if {[tcl::dict::get $o_opts_table -show_edge]} { - #title is considered part of the edge ? - set offset 1 ;#make configurable? - set titlepad [tcl::string::repeat $TSUB $offset] - if {[tcl::dict::get $o_opts_table -title] ne ""} { - set titlealign [tcl::dict::get $o_opts_table -titlealign] - switch -- $titlealign { - left { - set tstring $titlepad[tcl::dict::get $o_opts_table -title] - } - right { - set tstring [tcl::dict::get $o_opts_table -title]$titlepad - } - default { - set tstring [tcl::dict::get $o_opts_table -title] - } - } - set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] - switch -- $opt_titletransparent { - 0 { - set mapchar "" - } - 1 { - set mapchar " " - } - default { - #won't work if not a single char - review - check also frame behaviour - set mapchar $opt_titletransparent - } - } - if {$mapchar ne ""} { - set tstring [tcl::string::map [list $mapchar $TSUB] $tstring] - } - set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] - } - } - return $table - } else { - return "No columns matched" - } - } - method print_bodymatrix {} { - #*** !doctools - #[call class::table [method print_bodymatrix]] - #[para] output the matrix string corresponding to the body data using the matrix 2string format - #[para] this will be a table without borders,headers,title etc and will exclude additional ANSI applied due to table, row or column settings. - #[para] If the original cell data itself contains ANSI - the output will still contain those ansi codes. - # - - - set m [my as_matrix] - $m format 2string - } - - #*** !doctools - #[list_end] - }] - #*** !doctools - # [list_end] [comment {- end enumeration provider_classes }] - #[list_end] [comment {- end itemized list textblock::class groupings -}] - } - } -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# -#Note: A textblock does not necessarily have lines the same length - either in number of characters or print-width -# -tcl::namespace::eval textblock { - variable frametypes - set frametypes [list light light_b light_c heavy heavy_b heavy_c arc arc_b arc_c double block block1 block2 block2hack ascii altg] - #class::table needs to be able to determine valid frametypes - proc frametypes {} { - variable frametypes - return $frametypes - } - - 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 *} - tcl::namespace::import ::term::ansi::code::macros::cd::* - tcl::namespace::eval ::term::ansi::code::macros::cd {tcl::namespace::export -clear} - } - 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 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 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} - $t configure_column 3 -header_colspans {1 0 2 0 0} - $t configure -show_header 1 -ansiborder_header [a+ cyan] - return $t - } - proc spantest3 {} { - 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 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} - $t configure_column 2 -header_colspans {0 0 0 0 1 2} - $t configure_column 4 -headers {"4" "444" "" "" "" "44"} - $t configure -show_header 1 -ansiborder_header [a+ cyan] - return $t - } - - punk::args::definition { - @id -id ::textblock::periodic - @cmd -name textblock::periodic -help "A rudimentary periodic table - This is primarily a test of textblock::class::table" - - -return -default table\ - -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 - -forcecolour -default 0 -type boolean -help "If punk::colour is off - this enables the produced table to still be ansi coloured" - @values -min 0 -max 0 - } - - proc periodic {args} { - #For an impressive interactive terminal app (javascript) - # see: https://github.com/spirometaxas/periodic-table-cli - set opts [dict get [punk::args::get_by_id ::textblock::periodic $args] opts] - set opt_return [tcl::dict::get $opts -return] - if {[tcl::dict::get $opts -forcecolour]} { - set fc forcecolour - } else { - set fc "" - } - - #examples ptable.com - set elements [list\ - 1 H "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" He\ - 2 Li Be "" "" "" "" "" "" "" "" "" "" B C N O F Ne\ - 3 Na Mg "" "" "" "" "" "" "" "" "" "" Al Si P S Cl Ar\ - 4 K Ca Sc Ti V Cr Mn Fe Co Ni Cu Zn Ga Ge As Se Br Kr\ - 5 Rb Sr Y Zr Nb Mo Tc Ru Rh Pd Ag Cd In Sn Sb Te I Xe\ - 6 Cs Ba "" Hf Ta W Re Os Ir Pt Au Hg Tl Pb Bi Po At Rn\ - 7 Fr Ra "" Rf Db Sg Bh Hs Mt Ds Rg Cn Nh Fl Mc Lv Ts Og\ - " " " " " " " " " " " " " " " " " " " " " " " " "" "" "" "" "" "" ""\ - "" "" "" 6 La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu\ - "" "" "" 7 Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr\ - ] - - set type_colours [list] - - set ecat [tcl::dict::create] - - set cat_alkaline_earth [list Be Mg Ca Sr Ba Ra] - set ansi [a+ {*}$fc web-black Web-gold] - set val [list ansi $ansi cat alkaline_earth] - foreach e $cat_alkaline_earth { - tcl::dict::set ecat $e $val - } - - 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 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 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 black Term-orange1] - set val [list ansi $ansi cat transition_metals] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list Al Ga In Sn Tl Pb Bi Po] - set ansi [a+ {*}$fc web-black Web-lightskyblue] - set val [list ansi $ansi cat post_transition_metals] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list B Si Ge As Sb Te At] - #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 - } - - set cat [list He Ne Ar Kr Xe Rn] - set ansi [a+ {*}$fc web-black Web-orchid] - set val [list ansi $ansi cat noble_gases] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr] - set ansi [a+ {*}$fc web-black Web-plum] - set val [list ansi $ansi cat actinoids] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - 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 black Term-tan] - set val [list ansi $ansi cat lanthanoids] - foreach e $cat { - tcl::dict::set ecat $e $val - } - - set ansi [a+ {*}$fc web-black Web-whitesmoke] - set val [list ansi $ansi cat other] - foreach e [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] { - tcl::dict::set ecat $e $val - } - - set elements1 [list] - set RST [a+] - foreach e $elements { - if {[tcl::dict::exists $ecat $e]} { - set ansi [tcl::dict::get $ecat $e ansi] - #lappend elements1 [textblock::pad $ansi$e -width 2 -which right] - #no need to pad here - table column_configure -textalign default of left will do the work of padding right anyway - lappend elements1 $ansi$e - } else { - lappend elements1 $e - } - } - - set t [list_as_table -columns 19 -return tableobject $elements1] - #(defaults to show_hseps 0) - - #todo - keep simple table with symbols as base - map symbols to descriptions etc for more verbose table options - - set header_0 [list 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18] - set c 0 - foreach h $header_0 { - $t configure_column $c -headers [list $h] -minwidth 2 - incr c - } - set ccount [$t column_count] - for {set c 0} {$c < $ccount} {incr c} { - $t configure_column $c -minwidth 3 - } - if {[tcl::dict::get $opts -compact]} { - #compact defaults - but let explicit arguments override - set conf [dict create -show_vseps 0 -show_header 0 -show_edge 0] - } else { - set conf [dict create -show_vseps 1 -show_header 1 -show_edge 1] - } - dict for {k v} $conf { - if {[dict get $opts $k] ne ""} { - dict set conf $k [dict get $opts $k] - } - } - - set moreopts [dict create\ - -frametype_header light\ - -ansiborder_header [a+ {*}$fc brightwhite]\ - -ansibase_header [a+ {*}$fc Black]\ - -ansibase_body [a+ {*}$fc Black]\ - -ansiborder_body [a+ {*}$fc black]\ - -frametype block - ] - $t configure {*}[dict merge $conf $moreopts] - - #-ansiborder_header [a+ {*}$fc web-white]\ - - if {$opt_return eq "table"} { - 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 -checkargs 0 -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] - } else { - set output [$t print] - } - $t destroy - return $output - } - return $t - } - - proc bookend_lines {block start {end "\x1b\[m"}} { - set out "" - foreach ln [split $block \n] { - append out $start $ln $end \n - } - return [string range $out 0 end-1] - } - proc ansibase_lines {block {newprefix ""}} { - set base "" - set out "" - if {$newprefix eq ""} { - foreach ln [split $block \n] { - set parts [punk::ansi::ta::split_codes $ln] - if {[lindex $parts 0] eq ""} { - if {[lindex $parts 1] ne "" && ![punk::ansi::codetype::is_sgr_reset [lindex $parts 1]]} { - set base [lindex $parts 1] - append out $base - } else { - append out $base - } - } else { - #leading plaintext - maintain our base - append out $base [lindex $parts 0] [lindex $parts 1] - } - - set code_idx 3 - foreach {pt code} [lrange $parts 2 end] { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set parts [linsert $parts $code_idx+1 $base] - } - incr code_idx 2 - } - append out {*}[lrange $parts 2 end] \n - } - return [string range $out 0 end-1] - } else { - set base $newprefix - foreach ln [split $block \n] { - set parts [punk::ansi::ta::split_codes $ln] - set code_idx 1 - set offset 0 - foreach {pt code} $parts { - if {$code_idx == 1} { - #first pt & code - if {$pt ne ""} { - #leading plaintext - set parts [linsert $parts 0 $base] - incr offset - } - } - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set parts [linsert $parts [expr {$code_idx+1+$offset}] $base] - incr offset - } - incr code_idx 2 - } - append out {*}$parts \n - } - return [string range $out 0 end-1] - } - } - - set FRAMETYPES [textblock::frametypes] - punk::args::definition [punk::lib::tstr -return string { - @id -id ::textblock::list_as_table - @cmd -name "textblock::list_as_table" -help\ - "Display a list in a bordered table - " - - -return -default table -choices {table tableobject} - -frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\ - -help "frame type or dict for custom frame" - -show_edge -default "" -type boolean\ - -help "show outer border of table" - -show_seps -default "" -type boolean - -show_vseps -default "" -type boolean\ - -help "Show vertical table separators" - -show_hseps -default "" -type boolean\ - -help "Show horizontal table separators - (default 0 if no existing -table supplied)" - -table -default "" -type string\ - -help "existing table object to use" - -colheaders -default "" -type list\ - -help "list of lists. list of column header values. Outer list must match number of columns" - -header -default "" -type list -multiple 1\ - -help "Each supplied -header argument is a header row. - The number of values for each must be <= number of columns" - -show_header -type boolean\ - -help "Whether to show a header row. - Omit for unspecified/automatic, - in which case it will display only if -headers list was supplied." - -action -default "append" -choices {append replace}\ - -help "row insertion method if existing -table is supplied - if append is chosen the new values will always start at the first column" - -columns -default "" -type integer\ - -help "Number of table columns - Will default to 2 if not using an existing -table object" - - @values -min 0 -max 1 - datalist -default {} -type list -help "flat list of table cell values which will be wrapped based on -columns value" - }] - - proc list_as_table {args} { - set FRAMETYPES [textblock::frametypes] - set argd [punk::args::get_by_id ::textblock::list_as_table $args] - - set opts [dict get $argd opts] - set datalist [dict get $argd values datalist] - - set existing_table [dict get $opts -table] - set opt_columns [dict get $opts -columns] - set count [llength $datalist] - - set is_new_table 0 - if {$existing_table ne ""} { - if {[tcl::namespace::tail [info object class $existing_table]] ne "table"} { - error "textblock::list_as_table error -table must be an existing table object (e.g set t \[textblock::class::table new\])" - } - set t $existing_table - foreach prop {-frametype -show_edge -show_seps -show_vseps -show_hseps} { - if {[tcl::dict::get $opts $prop] ne ""} { - $t configure $prop [tcl::dict::get $opts $prop] - } - } - if {[dict get $opts -action] eq "replace"} { - $t row_clear - } - set cols [$t column_count] - if {[tcl::string::is integer -strict $opt_columns]} { - if {$opt_columns > $cols} { - set extra [expr {$opt_columns - $cols}] - for {set c 0} {$c < $extra} {incr c} { - $t add_column - } - } elseif {$opt_columns < $cols} { - #todo - auto add blank values in the datalist - error "Number of columns requested: $opt_columns is less than existing number of columns $cols - not yet supported" - } - set cols [$t column_count] - } - } else { - set is_new_table 1 - set colheaders {} - if {[tcl::dict::get $opts -colheaders] ne ""} { - set colheaders [dict get $opts -colheaders] - } else { - set colheaders [list] - } - set r 0 - foreach ch $colheaders { - set rows [llength $ch] - if {$r < $rows} { - set r $rows - } - } - if {[llength [tcl::dict::get $opts -header]]} { - foreach hrow [tcl::dict::get $opts -header] { - set c 0 - foreach cell $hrow { - if {[llength $colheaders] < $c+1} { - lappend colheaders [lrepeat $r {}] - } - set colinfo [lindex $colheaders $c] - if {$r > [llength $colinfo]} { - set diff [expr {$r - [llength $colinfo]}] - lappend colinfo {*}[lrepeat $diff {}] - } - lappend colinfo $cell - lset colheaders $c $colinfo - incr c - } - incr r - } - } - - - if {[llength $colheaders] > 0} { - if {![tcl::dict::exists $opts received -show_header]} { - set show_header 1 - } else { - set show_header [tcl::dict::get $opts -show_header] - } - } else { - if {![tcl::dict::exists $opts received -show_header]} { - set show_header 0 - } else { - set show_header [tcl::dict::get $opts -show_header] - } - } - - if {[tcl::string::is integer -strict $opt_columns]} { - set cols $opt_columns - if {[llength $colheaders] && $cols != [llength $colheaders]} { - error "list_as_table number of columns ($cols) doesn't match supplied number of headers ([llength $colheaders])" - } - } else { - #review - if {[llength $colheaders]} { - set cols [llength $colheaders] - } else { - set cols 2 ;#seems a reasonable default - } - } - #defaults for new table only - #if {[tcl::dict::get $opts -show_seps] eq ""} { - # tcl::dict::set opts -show_seps 1 - #} - if {[tcl::dict::get $opts -show_edge] eq ""} { - tcl::dict::set opts -show_edge 1 - } - if {[tcl::dict::get $opts -show_vseps] eq ""} { - tcl::dict::set opts -show_vseps 1 - } - if {[tcl::dict::get $opts -show_hseps] eq ""} { - tcl::dict::set opts -show_hseps 0 - } - - set t [textblock::class::table new\ - -show_header $show_header\ - -show_edge [tcl::dict::get $opts -show_edge]\ - -frametype [tcl::dict::get $opts -frametype]\ - -show_seps [tcl::dict::get $opts -show_seps]\ - -show_vseps [tcl::dict::get $opts -show_vseps]\ - -show_hseps [tcl::dict::get $opts -show_hseps]\ - ] - if {[llength $colheaders]} { - for {set c 0} {$c < $cols} {incr c} { - $t add_column -headers [lindex $colheaders $c] - } - } else { - for {set c 0} {$c < $cols} {incr c} { - $t add_column -headers [list $c] - } - } - } - - set full_rows [expr {$count / $cols}] - set last_items [expr {$count % $cols}] - - - set rowdata [list] - set row [list] - set i 0 - if {$full_rows > 0} { - for {set r 0} {$r < $full_rows} {incr r} { - set j [expr {$i + ($cols -1)}] - set row [lrange $datalist $i $j] - incr i $cols - lappend rowdata $row - } - } - if {$last_items > 0} { - set idx [expr {$last_items -1}] - lappend rowdata [lrange $datalist end-$idx end] - } - foreach row $rowdata { - set shortfall [expr {$cols - [llength $row]}] - if {$shortfall > 0} { - #set row [concat $row [lrepeat $shortfall ""]] - lappend row {*}[lrepeat $shortfall ""] - } - $t add_row $row - } - #puts stdout $rowdata - if {[tcl::dict::get $opts -return] eq "table"} { - set result [$t print] - if {$is_new_table} { - $t destroy - } - return $result - } else { - return $t - } - } - #return a homogenous block of characters - ie lines all same length, all same character - #printing-width in terminal columns is not necessarily same as blockwidth even if a single char is passed (could be full-width unicode character) - #This can have ansi SGR codes - but to repeat blocks containing ansi-movements, the block should first be rendered to a static output with something like overtype::left - proc block {blockwidth blockheight {char " "}} { - if {$blockwidth < 0} { - error "textblock::block blockwidth must be an integer greater than or equal to zero" - } - if {$blockheight <= 0} { - error "textblock::block blockheight must be a positive integer" - } - if {$char eq ""} {return ""} - #using tcl::string::length is ok - if {[tcl::string::length $char] == 1} { - set row [tcl::string::repeat $char $blockwidth] - set mtrx [lrepeat $blockheight $row] - return [::join $mtrx \n] - } else { - set charblock [tcl::string::map [list \r\n \n] $char] - if {[tcl::string::last \n $charblock] >= 0} { - if {$blockwidth > 1} { - #set row [.= val $charblock {*}[lrepeat [expr {$blockwidth -1}] |> piper_blockjoin $charblock]] ;#building a repeated "|> command arg" list to evaluate as a pipeline. (from before textblock::join could take arbitrary num of blocks ) - set row [textblock::join_basic -- {*}[lrepeat $blockwidth $charblock]] - } else { - set row $charblock - } - } else { - set row [tcl::string::repeat $char $blockwidth] - } - set mtrx [lrepeat $blockheight $row] - return [::join $mtrx \n] - } - } - proc testblock {size {colour ""}} { - if {$size <1 || $size > 15} { - error "textblock::testblock only sizes between 1 and 15 inclusive supported" - } - set rainbow_list [list] - lappend rainbow_list {30 47} ;#black White - lappend rainbow_list {31 46} ;#red Cyan - lappend rainbow_list {32 45} ;#green Purple - lappend rainbow_list {33 44} ;#yellow Blue - lappend rainbow_list {34 43} ;#blue Yellow - lappend rainbow_list {35 42} ;#purple Green - lappend rainbow_list {36 41} ;#cyan Red - lappend rainbow_list {37 40} ;#white Black - lappend rainbow_list {black Yellow} - lappend rainbow_list red - lappend rainbow_list green - lappend rainbow_list yellow - lappend rainbow_list blue - lappend rainbow_list purple - lappend rainbow_list cyan - lappend rainbow_list {white Red} - - set rainbow_direction "horizontal" - set vpos [lsearch $colour vertical] - if {$vpos >= 0} { - set rainbow_direction vertical - set colour [lremove $colour $vpos] - } - set hpos [lsearch $colour horizontal] - if {$hpos >=0} { - #horizontal is the default and superfluous but allowed for symmetry - set colour [lremove $colour $hpos] - } - - - - set chars [list {*}[punk::lib::range 1 9] A B C D E F] - set charsubset [lrange $chars 0 $size-1] - if {"noreset" in $colour} { - set RST "" - } else { - set RST [a] - } - if {"rainbow" in $colour && $rainbow_direction eq "vertical"} { - #column first - colour change each column - set c [::join $charsubset \n] - - set clist [list] - for {set i 0} {$i <$size} {incr i} { - set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $i]] $colour] - set ansi [a+ {*}$colour2] - - set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] - lappend clist ${ansicode}$c$RST - } - if {"noreset" in $colour} { - return [textblock::join_basic -ansiresets 0 -- {*}$clist] - } else { - return [textblock::join_basic -- {*}$clist] - } - } elseif {"rainbow" in $colour} { - #direction must be horizontal - set block "" - for {set r 0} {$r < $size} {incr r} { - set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $r]] $colour] - set ansi [a+ {*}$colour2] - set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] - set row "$ansicode" - foreach c $charsubset { - append row $c - } - append row $RST - append block $row\n - } - set block [tcl::string::trimright $block \n] - return $block - } else { - #row first - - set rows [list] - foreach ch $charsubset { - lappend rows [tcl::string::repeat $ch $size] - } - set block [::join $rows \n] - if {$colour ne ""} { - set block [a+ {*}$colour]$block$RST - } - return $block - } - } - interp alias {} testblock {} textblock::testblock - - #todo - consider 'elastic tabstops' for textblocks where tab acts as a column separator and adjacent lines with the same number of tabs form a sort of table - proc width {textblock} { - #backspaces, vertical tabs ? - if {$textblock eq ""} { - return 0 - } - #textutil::tabify is a reasonable hack when there are no ansi SGR codes - but probably not always what we want even then - review - if {[tcl::string::last \t $textblock] >= 0} { - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set textblock [textutil::tabify::untabify2 $textblock $tw] - } - if {[string length $textblock] > 1 && [punk::ansi::ta::detect $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}]] - } - return [punk::char::ansifreestring_width $textblock] - } - #gather info about whether ragged (samewidth each line = false) and min width - proc widthinfo {textblock} { - #backspaces, vertical tabs ? - if {$textblock eq ""} { - return [dict create width 0 minwidth 0 ragged 0] - } - #textutil::tabify is a reasonable hack when there are no ansi SGR codes - but probably not always what we want even then - review - if {[tcl::string::last \t $textblock] >= 0} { - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set textblock [textutil::tabify::untabify2 $textblock $tw] - } - if {[string length $textblock] > 1 && [punk::ansi::ta::detect $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}]] - set widths [lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}] - set max [tcl::mathfunc::max {*}$widths] - set min [tcl::mathfunc::min {*}$widths] - set ragged [expr {$min != $max}] - return [dict create width $max minwidth $min ragged $ragged] - } - #single line - set w [punk::char::ansifreestring_width $textblock] - return [dict create width $w minwidth $w ragged 0] - } - #when we know the block is uniform in width - just examine topline - proc widthtopline {textblock} { - set firstnl [tcl::string::first \n $textblock] - if {$firstnl >= 0} { - set tl [tcl::string::range $textblock 0 $firstnl] - } else { - set tl $textblock - } - if {[punk::ansi::ta::detect $tl]} { - set tl [punk::ansi::ansistripraw $tl] - } - return [punk::char::ansifreestring_width $tl] - } - #uses tcl's tcl::string::length on each line. Length will include chars in ansi codes etc - this is not a 'width' determining function. - proc string_length_line_max {textblock} { - #tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}] - set max 0 - foreach ln [split $textblock \n] { - if {[tcl::string::length $ln] > $max} {set max [tcl::string::length $ln]} - } - return $max - } - #*slightly* slower - #proc string_length_line_max {textblock} { - # tcl::mathfunc::max {*}[lmap v [split $textblock \n] {tcl::string::length $v}] - #} - proc string_length_line_min textblock { - tcl::mathfunc::min {*}[lmap v [split $textblock \n] {tcl::string::length $v}] - } - - proc height {textblock} { - #This is the height as it will/would-be rendered - not the number of input lines purely in terms of le - #empty string still has height 1 (at least for left-right/right-left languages) - - #vertical tab on a proper terminal should move directly down. - #Whether or not the terminal in use actually does this - we need to calculate as if it does. (there might not even be a terminal) - - set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list - return [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le - } - #MAINTENANCE - same as overtype::blocksize? - proc size {textblock} { - if {$textblock eq ""} { - 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 - } - #strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack - if {[tcl::string::last \t $textblock] >= 0} { - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set textblock [textutil::tabify::untabify2 $textblock $tw] - } - #ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests - if {[string length $textblock] > 1 && [punk::ansi::ta::detect $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}]] - set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] - } else { - set width [punk::char::ansifreestring_width $textblock] - } - set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list - #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 [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize ]] width height - } - proc size2 {textblock} { - if {$textblock eq ""} { - 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 - } - #strangely - tcl::string::last (windows tcl8.7 anway) is faster than tcl::string::first for large strings when the needle not in the haystack - if {[tcl::string::last \t $textblock] >= 0} { - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set textblock [textutil::tabify::untabify2 $textblock $tw] - } - #ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests - if {[string length $textblock] > 1 && [punk::ansi::ta::detect $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}]] - set lines [split $textblock \n] - set num_le [expr {[llength $lines]-1}] - #set width [tcl::mathfunc::max {*}[lmap v $lines {::punk::char::ansifreestring_width $v}]] - set width 0 - foreach ln $lines { - set w [::punk::char::ansifreestring_width $ln] - if {$w > $width} { - set width $w - } - } - } else { - set num_le 0 - set width [punk::char::ansifreestring_width $textblock] - } - #set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list - #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 [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [tcl::dict::values [blocksize ]] width height - } - proc size_as_opts {textblock} { - set sz [size $textblock] - return [dict create -width [dict get $sz width] -height [dict get $sz height]] - } - proc size_as_list {textblock} { - set sz [size $textblock] - return [list [dict get $sz width] [dict get $sz height]] - } - #must be able to handle block as string with or without newlines - #if no newlines - attempt to treat as a list - #must handle whitespace-only string,list elements, and/or lines. - #reviewing 2024 - this seems like too much magic! - proc width1 {block} { - if {$block eq ""} { - return 0 - } - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - 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 [ansistrip $v]}]] - } - if {[catch {llength $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 [ansistrip $v]}]] - } - - #we shouldn't make textblock depend on the punk pipeline system - #pipealias ::textblock::padleft .= {list $input [tcl::string::repeat " " $indent]} |/0,padding/1> punk:lib::lines_as_list -- |> .= {lmap v $data {overtype::right $padding $v}} |> punk::lib::list_as_lines -- punk::lib::lines_as_list -- |> .= {lmap v $data {overtype::left $padding $v}} |> punk::lib::list_as_lines -- |? ?-which right|left|centre? ?-known_hasansi \"\"|? ?-known_blockwidth \"\"|? ?-width auto|? ?-within_ansi 1|0?" - foreach {k v} $args { - switch -- $k { - -padchar - -which - -known_hasansi - -known_samewidth - -known_blockwidth - -width - -overflow - -within_ansi { - tcl::dict::set opts $k $v - } - default { - error "textblock::pad unrecognised option '$k'. Usage: $usage" - } - } - } - # -- --- --- --- --- --- --- --- --- --- - set padchar [tcl::dict::get $opts -padchar] - #if padchar width (screen width) > 1 - length calculations will not be correct - #we will allow tokens longer than 1 - as the caller may want to post-process on the token whilst preserving previous leading/trailing spaces, e.g with a tcl::string::map - #The caller may also use ansi within the padchar - although it's unlikely to be efficient. - # -- --- --- --- --- --- --- --- --- --- - set known_whiches [list l left r right c center centre] - set opt_which [tcl::string::tolower [tcl::dict::get $opts -which]] - switch -- $opt_which { - center - centre - c { - set which c - } - left - l { - set which l - } - right - r { - set which r - } - default { - error "textblock::pad unrecognised value for -which option. Known values $known_whiches" - } - } - # -- --- --- --- --- --- --- --- --- --- - set opt_width [tcl::dict::get $opts -width] - switch -- $opt_width { - "" - auto { - set width auto - } - default { - if {![tcl::string::is integer -strict $opt_width] || $opt_width < 0} { - error "textblock::pad -width must be an integer >=0" - } - set width $opt_width - } - } - # -- --- --- --- --- --- --- --- --- --- - set opt_withinansi [tcl::dict::get $opts -within_ansi] - switch -- $opt_withinansi { - 0 - 1 {} - default { - set opt_withinansi 2 - } - } - # -- --- --- --- --- --- --- --- --- --- - set known_blockwidth [tcl::dict::get $opts -known_blockwidth] - set known_samewidth [tcl::dict::get $opts -known_samewidth] ;# if true - we have a known non-ragged block, if false - could be either. - set datawidth "" - if {$width eq "auto"} { - #for auto - we - if {$known_blockwidth eq ""} { - if {$known_samewidth ne "" && $known_samewidth} { - set datawidth [textblock::widthtopline $block] - } else { - #set datawidth [textblock::width $block] - set widthinfo [textblock::widthinfo $block] - set known_samewidth [expr {![dict get $widthinfo ragged]}] ;#review - a false value here is definite, distinguished from unknown which would be empty string - so we can take advantage of it - set datawidth [dict get $widthinfo width] - } - } else { - set datawidth $known_blockwidth - } - set width $datawidth ;# this is the width we want to pad out to - #assert datawidth has been set to widest line, taking ansi & 2wide chars into account - } else { - #only call width functions if known_samewidth - otherwise let the pad algorithm below determine it as we go - if {$known_samewidth ne "" && $known_samewidth} { - if {$known_blockwidth eq ""} { - set datawidth [textblock::widthtopline $block - } else { - set datawidth $known_blockwidth - } - } - #assert datawidth may still be empty string - } - #assertion - #we can now use the states of datawidth and known_samewidth to determine if algorithm below should calculate widths as it goes. - - 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 - 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? - #experimental fallback to supposedly faster simpler 'format' but we still need to compensate for double-width or non-printing chars - and it won't work on strings with ansi SGR codes - #review - surprisingly, this doesn't seem to be a performance win - #No detectable diff on small blocks - slightly worse on large blocks - # if {($padchar eq " " || $padchar eq "0") && ![punk::ansi::ta::detect $block]} { - # #This will still be wrong for example with diacritics on terminals that don't collapse the space following a diacritic, and don't correctly report cursor position - # #(i.e as at 2024 - lots of them) wezterm on windows at least does the right thing. - # set block [tcl::string::map [list \r\n \n] $block] - # if {$which eq "l"} { - # set fmt "%+${padchar}*s" - # } else { - # set fmt "%-${padchar}*s" - # } - # foreach ln [split $block \n] { - # #set lnwidth [punk::char::ansifreestring_width $ln] - # set lnwidth [punk::char::grapheme_width_cached $ln] - # set lnlen [tcl::string::length $ln] - # set diff [expr $lnwidth - $lnlen] - # #we need trickwidth to get format to pad a string with a different terminal width compared to string length - # set trickwidth [expr {$width - $diff}] ;#may 'subtract' a positive or negative int (ie will add to trickwidth if negative) - # lappend lines [format $fmt $trickwidth $ln] - # } - # return [::join $lines \n] - # } - - #todo? special case trailing double-reset - insert between resets? - set lnum 0 - - set known_hasansi [tcl::dict::get $opts -known_hasansi] - if {$known_hasansi eq ""} { - set block_has_ansi [punk::ansi::ta::detect $block] - } else { - set block_has_ansi $known_hasansi - } - if {$block_has_ansi} { - set parts [punk::ansi::ta::split_codes $block] - } else { - #single plaintext part - set parts [list $block] - } - - 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}] - if {$has_nl} { - set pt [tcl::string::map [list \r\n \n] $pt] - set partlines [split $pt \n] - } else { - set partlines [list $pt] - } - set last [expr {[llength $partlines]-1}] - set p 0 - foreach pl $partlines { - lappend line_chunks $pl - #incr line_len [punk::char::ansifreestring_width $pl] - if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} { - incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW - } - if {$p != $last} { - #do padding - if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} { - set missing [expr {$width - $line_len}] - } else { - set missing [expr {$width - $datawidth}] - } - if {$missing > 0} { - #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 - } - r-1 { - if {[lindex $line_chunks end] eq ""} { - set line_chunks [linsert $line_chunks end-2 $pad] - } else { - lappend line_chunks $pad - } - } - r-2 { - lappend line_chunks $pad - } - l-0 { - set line_chunks [linsert $line_chunks 0 $pad] - } - l-1 { - if {[lindex $line_chunks 0] eq ""} { - set line_chunks [linsert $line_chunks 2 $pad] - } else { - set line_chunks [linsert $line_chunks 0 $pad] - } - } - l-2 { - if {$lnum == 0} { - if {[lindex $line_chunks 0] eq ""} { - set line_chunks [linsert $line_chunks 2 $pad] - } else { - set line_chunks [linsert $line_chunks 0 $pad] - } - } else { - set line_chunks [linsert $line_chunks 0 $pad] - } - } - } - } - lappend lines [::join $line_chunks ""] - set line_chunks [list] - set line_len 0 - incr lnum - } - incr p - } - } else { - #we need to store empties in order to insert text in the correct position relative to leading/trailing ansi codes - lappend line_chunks "" - } - #don't let trailing empty ansi affect the line_chunks length - if {$ansi ne ""} { - lappend line_chunks $ansi ;#don't update line_len - review - ansi codes with visible content? - } - } - #pad last line - if {$known_samewidth eq "" || ($known_samewidth ne "" && !$known_samewidth) || $datawidth eq ""} { - set missing [expr {$width - $line_len}] - } else { - set missing [expr {$width - $datawidth}] - } - if {$missing > 0} { - 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 - } - r-1 { - if {[lindex $line_chunks end] eq ""} { - set line_chunks [linsert $line_chunks end-2 $pad] - } else { - lappend line_chunks $pad - } - } - r-2 { - if {[lindex $line_chunks end] eq ""} { - set line_chunks [linsert $line_chunks end-2 $pad] - } else { - lappend line_chunks $pad - } - #lappend line_chunks $pad - } - l-0 { - #if {[lindex $line_chunks 0] eq ""} { - # set line_chunks [linsert $line_chunks 2 $pad] - #} else { - # set line_chunks [linsert $line_chunks 0 $pad] - #} - set line_chunks [linsert $line_chunks 0 $pad] - } - l-1 { - #set line_chunks [linsert $line_chunks 0 $pad] - set line_chunks [_insert_before_text_or_last_ansi $pad $line_chunks] - } - l-2 { - set line_chunks [linsert $line_chunks 0 $pad] - } - } - } - lappend lines [::join $line_chunks ""] - return [::join $lines \n] - } - - #left insertion into a list resulting from punk::ansi::ta::split_codes or split_codes_single - #resulting list is no longer a valid ansisplit list - proc _insert_before_text_or_last_ansi {str ansisplits} { - if {[llength $ansisplits] == 1} { - #ansisplits was a split on plaintext only - return [list $str [lindex $ansisplits 0]] - } elseif {[llength $ansisplits] == 0} { - return [list $str] - } - if {[llength $ansisplits] %2 != 1} { - error "_insert_before_text_or_last_ansi ansisplits list is not a valid resultlist from an ansi split - must be odd number of elements pt,ansi,pt,ansi...pt" - } - set out [list] - set i 0 - set i_last_code [expr {[llength $ansisplits]-3}] ;#would normally be -2 - but our i is jumping to each pt - not every element - foreach {pt code} $ansisplits { - if {$pt ne ""} { - return [lappend out $str {*}[lrange $ansisplits $i end]] - } - if {$i == $i_last_code} { - return [lappend out $str {*}[lrange $ansisplits $i end]] - } - #code being empty can only occur when we have reached last pt - #we have returned by then. - lappend out $code - incr i 2 - } - error "_insert_before_text_or_last_ansi failed on input str:[ansistring VIEW $str] ansisplits:[ansistring VIEW $ansisplits]" - } - proc pad_test {block} { - set width [textblock::width $block] - set padtowidth [expr {$width + 10}] - set left0 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which left -within_ansi 0] - set left1 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which left -within_ansi 1] - set left2 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which left -within_ansi 2] - set right0 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which right -within_ansi 0] - set right1 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which right -within_ansi 1] - set right2 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which right -within_ansi 2] - - set testlist [list "within_ansi 0" $left0 $right0 "within_ansi 1" $left1 $right1 "within_ansi 2" $left2 $right2] - - set t [textblock::list_as_table -columns 3 -return tableobject $testlist] - $t configure_column 0 -headers [list "ansi"] - $t configure_column 1 -headers [list "Left"] - $t configure_column 2 -headers [list "Right"] - $t configure -show_header 1 - puts stdout [$t print] - return $t - } - - proc pad_test_blocklist {blocklist args} { - set opts [tcl::dict::create\ - -description ""\ - -blockheaders ""\ - ] - foreach {k v} $args { - switch -- $k { - -description - -blockheaders { - tcl::dict::set opts $k $v - } - default { - error "pad_test_blocklist unrecognised option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - set opt_blockheaders [tcl::dict::get $opts -blockheaders] - set bheaders [tcl::dict::create] - if {$opt_blockheaders ne ""} { - set b 0 - foreach h $opt_blockheaders { - if {$b < [llength $blocklist]} { - tcl::dict::set bheaders $b $h - } - incr b - } - } - - set b 0 - set blockinfo [tcl::dict::create] - foreach block $blocklist { - set width [textblock::width $block] - tcl::dict::set blockinfo $b width $width - set padtowidth [expr {$width + 3}] - tcl::dict::set blockinfo $b left0 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 0] - tcl::dict::set blockinfo $b left1 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 1] - tcl::dict::set blockinfo $b left2 [textblock::pad $block -width $padtowidth -padchar . -which left -within_ansi 2] - tcl::dict::set blockinfo $b right0 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 0] - tcl::dict::set blockinfo $b right1 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 1] - tcl::dict::set blockinfo $b right2 [textblock::pad $block -width $padtowidth -padchar . -which right -within_ansi 2] - incr b - } - - set r0 [list "0"] - set r1 [list "1"] - set r2 [list "2"] - set r3 [list "column\ncolours"] - - #1 - #test without table padding - #we need to textblock::join each item to ensure we don't get the table's own textblock::pad interfering - #(basically a mechanism to add extra resets at start and end of each line) - #dict for {b bdict} $blockinfo { - # lappend r0 [textblock::join [tcl::dict::get $blockinfo $b left0]] [textblock::join [tcl::dict::get $blockinfo $b right0]] - # lappend r1 [textblock::join [tcl::dict::get $blockinfo $b left1]] [textblock::join [tcl::dict::get $blockinfo $b right1]] - # lappend r2 [textblock::join [tcl::dict::get $blockinfo $b left2]] [textblock::join [tcl::dict::get $blockinfo $b right2]] - #} - - #2 - the more useful one? - tcl::dict::for {b bdict} $blockinfo { - lappend r0 [tcl::dict::get $blockinfo $b left0] [tcl::dict::get $blockinfo $b right0] - lappend r1 [tcl::dict::get $blockinfo $b left1] [tcl::dict::get $blockinfo $b right1] - lappend r2 [tcl::dict::get $blockinfo $b left2] [tcl::dict::get $blockinfo $b right2] - lappend r3 "" "" - } - - set rows [concat $r0 $r1 $r2 $r3] - - set column_ansi [a+ web-white Web-Gray] - - set t [textblock::list_as_table -columns [expr {1 + (2 * [tcl::dict::size $blockinfo])}] -return tableobject $rows] - $t configure_column 0 -headers [list [tcl::dict::get $opts -description] "within_ansi"] -ansibase $column_ansi - set col 1 - tcl::dict::for {b bdict} $blockinfo { - if {[tcl::dict::exists $bheaders $b]} { - set hdr [tcl::dict::get $bheaders $b] - } else { - set hdr "Block $b" - } - $t configure_column $col -headers [list $hdr "Left"] -minwidth [expr {$padtowidth + 2}] - $t configure_column $col -header_colspans 2 -ansibase $column_ansi - incr col - $t configure_column $col -headers [list "-" "Right"] -minwidth [expr {$padtowidth + 2}] -ansibase $column_ansi - incr col - } - $t configure -show_header 1 - puts stdout [$t print] - return $t - } - proc pad_example {} { - set headers [list] - set blocks [list] - - lappend blocks "[textblock::testblock 4 rainbow]" - lappend headers "rainbow 4x4\nresets at line extremes\nnothing trailing" - - lappend blocks "[textblock::testblock 4 rainbow][a]" - lappend headers "rainbow 4x4\nresets at line extremes\ntrailing reset" - - lappend blocks "[textblock::testblock 4 rainbow]\n[a+ Web-Green]" - lappend headers "rainbow 4x4\nresets at line extremes\ntrailing nl&green bg" - - lappend blocks "[textblock::testblock 4 {rainbow noreset}]" - lappend headers "rainbow 4x4\nno line resets\nnothing trailing" - - lappend blocks "[textblock::testblock 4 {rainbow noreset}][a]" - lappend headers "rainbow 4x4\nno line resets\ntrailing reset" - - lappend blocks "[textblock::testblock 4 {rainbow noreset}]\n[a+ Web-Green]" - lappend headers "rainbow 4x4\nno line resets\ntrailing nl&green bg" - - set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] - } - proc pad_example2 {} { - set headers [list] - set blocks [list] - lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n" - lappend headers "red on blue 4x4\nno inner resets\ntrailing nl" - - lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a]" - lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&reset" - - lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a+ Web-Green]" - lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&green bg" - - set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers] - } - - - #playing with syntax - - # pipealias ::textblock::join_width .= {list $lhs [tcl::string::repeat " " $w1] $rhs [tcl::string::repeat " " $w2]} {| - # /2,col1/1,col2/3 - # >} punk::lib::lines_as_list -- {| - # data2 - # >} .=lhs> punk::lib::lines_as_list -- {| - # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| - # >} punk::lib::list_as_lines -- } .=> punk::lib::lines_as_list -- {| - # data2 - # >} .=lhs> punk::lib::lines_as_list -- {| - # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| - # >} punk::lib::list_as_lines -- $rowcount} { - set rowcount [llength $bl] - } - lappend blocklists $bl - } - set outlines [list] - for {set r 0} {$r < $rowcount} {incr r} { - set row "" - for {set c 0} {$c < [llength $blocks]} {incr c} { - append row [lindex $blocklists $c $r] - } - lappend outlines $row - } - return [::join $outlines \n] - } - proc ::textblock::join_basic2 {args} { - #@cmd -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width. - # 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] - set ansiresets [tcl::dict::get $argd opts -ansiresets] - set blocks [tcl::dict::get $argd values blocks] - - #-ansireplays is always on (if ansi detected) - - # -- is a legimate block - #this makes for a somewhat messy api.. -- is required if first block is actually -- (or the very unlikely case the first block is intended to be -ansiresets) - - if {![llength $blocks]} { - return - } - set idx 0 - set fordata [list] - set colindices [list] - foreach b $blocks { - if {[punk::ansi::ta::detect $b]} { - lappend fordata "v($idx)" [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] - } else { - lappend fordata "v($idx)" [split $b \n] - } - lappend colindices $idx - incr idx - } - set outlines [list] - foreach {*}$fordata { - set row {} - foreach colidx $colindices { - lappend row $v($colidx) - } - lappend outlines [::join $row ""] - } - return [::join $outlines \n] - } - #for joining 'rendered' blocks of plain or ansi text. Being 'rendered' means they are without ansi movement sequences as these have been processed - #they may however still be 'ragged' ie differing line lengths - proc ::textblock::join {args} { - #set argd [punk::args::get_dict { - # blocks -type string -multiple 1 - #} $args] - #set opts [tcl::dict::get $argd opts] - #set blocks [tcl::dict::get $argd values blocks] - - #-ansireplays is always on (if ansi detected) - - #we will support -- at posn 0 and 2 only to allow an optional single option pair for -ansiresets - #textblock::join is already somewhat expensive - we don't want to do much argument processing - #also "--" is a legitimate joining block - so we need to support that too without too much risk of misinterpretation - #this makes for a somewhat messy api.. -- is required if first block is actually -- (or the very unlikely case the first block is intended to be -ansiresets) - set ansiresets auto - switch -- [lindex $args 0] { - -- { - set blocks [lrange $args 1 end] - } - -ansiresets { - if {[lindex $args 2] eq "--"} { - set blocks [lrange $args 3 end] - set ansiresets [lindex $args 1] - } else { - error "end of opts marker -- is mandatory." - } - } - default { - 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" - } - } - } - } - - if {![llength $blocks]} { - return - } - - set idx 0 - set blocklists [list] - set rowcount 0 - foreach b $blocks { - #we need the width of a rendered block for per-row renderline calls or padding - #we may as well use widthinfo to also determine raggedness state to pass on to pad function - #set bwidth [width $b] - set widthinfo [widthinfo $b] - set bwidth [dict get $widthinfo width] - set is_samewidth [expr {![dict get $widthinfo ragged]}] - - #set c($idx) [tcl::string::repeat " " [set w($idx)]] - #fairly commonly a block may be a vertical list of chars e.g something like 1\n2\n3 or -\n-\n-\n- - #for determining a shortcut to avoid unnecessary ta::detect - (e.g width <=1) we can't use result of textblock::width as it strips ansi. - #testing of any decent size block line by line - even with max_string_length_line is slower than ta::detect anyway. - - #blocks passed to join can be ragged - so we can't pass -known_samewidth to pad - if {[punk::ansi::ta::detect $b]} { - # - we need to join to use pad - even though we then need to immediately resplit REVIEW (make line list version of pad?) - set replay_block [::join [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] \n] - set bl [split [textblock::pad $replay_block -known_hasansi 1 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n] - } else { - #each block is being rendered into its own empty column - we don't need resets if it has no ansi, even if blocks to left and right do have ansi - set bl [split [textblock::pad $b -known_hasansi 0 -known_samewidth $is_samewidth -known_blockwidth $bwidth -width $bwidth -which right -padchar " "] \n] - } - set rowcount [expr {max($rowcount,[llength $bl])}] - lappend blocklists $bl - set width($idx) $bwidth - incr idx - } - - set outlines [list] - for {set r 0} {$r < $rowcount} {incr r} { - set row "" - for {set c 0} {$c < [llength $blocklists]} {incr c} { - set cell [lindex $blocklists $c $r] - if {$cell eq ""} { - set cell [string repeat " " $width($c)] - } - append row $cell - } - lappend outlines $row - } - return [::join $outlines \n] - } - - proc ::textblock::join2 {args} { - #set argd [punk::args::get_dict { - # blocks -type string -multiple 1 - #} $args] - #set opts [tcl::dict::get $argd opts] - #set blocks [tcl::dict::get $argd values blocks] - - #-ansireplays is always on (if ansi detected) - - #we will support -- at posn 0 and 2 only to allow an optional single option pair for -ansiresets - #textblock::join is already somewhat expensive - we don't want to do much argument processing - #also "--" is a legitimate joining block - so we need to support that too without too much risk of misinterpretation - #this makes for a somewhat messy api.. -- is required if first block is actually -- (or the very unlikely case the first block is intended to be -ansiresets) - set ansiresets auto - switch -- [lindex $args 0] { - -- { - set blocks [lrange $args 1 end] - } - -ansiresets { - if {[lindex $args 2] eq "--"} { - set blocks [lrange $args 3 end] - set ansiresets [lindex $args 1] - } else { - error "end of opts marker -- is mandatory." - } - } - default { - 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" - } - } - } - } - - if {![llength $blocks]} { - return - } - - set idx 0 - set fordata [list] - set colindices [list] - foreach b $blocks { - set w($idx) [width $b] ;#we need the width of a rendered block for per-row renderline calls or padding - #set c($idx) [tcl::string::repeat " " [set w($idx)]] - #fairly commonly a block may be a vertical list of chars e.g something like 1\n2\n3 or -\n-\n-\n- - #for determining a shortcut to avoid unnecessary ta::detect - (e.g width <=1) we can't use result of textblock::width as it strips ansi. - #testing of any decent size block line by line - even with max_string_length_line is slower than ta::detect anyway. - if {[punk::ansi::ta::detect $b]} { - #lappend fordata "v($idx)" [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] - - # - we need to join to use pad - even though we then need to immediately resplit REVIEW (make line list version of pad?) - set replay_block [::join [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] \n] - lappend fordata "v($idx)" [split [textblock::pad $replay_block -known_hasansi 1 -known_blockwidth $w($idx) -width $w($idx) -which right -padchar " "] \n] - } else { - #each block is being rendered into its own empty column - we don't need resets if it has no ansi, even if blocks to left and right do have ansi - #lappend fordata "v($idx)" [split $b \n] - lappend fordata "v($idx)" [split [textblock::pad $b -known_hasansi 0 -known_blockwidth $w($idx) -width $w($idx) -which right -padchar " "] \n] - } - lappend colindices $idx - incr idx - } - - - - - set outlines [list] - #set colindices [lsort -integer -increasing [array names c]] - foreach {*}$fordata { - set row "" - foreach colidx $colindices { - #we know we have a single line, no ansi in underlay and no overflow required - so we can use renderline directly - #append row [overtype::renderline -width $w($colidx) -insert_mode 0 -info 0 $c($colidx) $v($colidx)] - #append row [textblock::pad $v($colidx) -width $w($colidx) -which right -padchar " "] - - #short blocks need to have empty lines padded too - if {$v($colidx) eq ""} { - append row [string repeat " " $w($colidx)] - } else { - append row $v($colidx) - } - } - lappend outlines $row - } - return [::join $outlines \n] - } - # This calls textblock::pad per cell :/ - proc ::textblock::join3 {args} { - #set argd [punk::args::get_dict { - # blocks -type string -multiple 1 - #} $args] - #set opts [tcl::dict::get $argd opts] - #set blocks [tcl::dict::get $argd values blocks] - - #-ansireplays is always on (if ansi detected) - - #we will support -- at posn 0 and 2 only to allow an optional single option pair for -ansiresets - #textblock::join is already somewhat expensive - we don't want to do much argument processing - #also "--" is a legitimate joining block - so we need to support that too without too much risk of misinterpretation - #this makes for a somewhat messy api.. -- is required if first block is actually -- (or the very unlikely case the first block is intended to be -ansiresets) - set ansiresets auto - switch -- [lindex $args 0] { - -- { - set blocks [lrange $args 1 end] - } - -ansiresets { - if {[lindex $args 2] eq "--"} { - set blocks [lrange $args 3 end] - set ansiresets [lindex $args 1] - } else { - error "end of opts marker -- is mandatory." - } - } - default { - 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" - } - } - } - } - - if {![llength $blocks]} { - return - } - - set idx 0 - set fordata [list] - set colindices [list] - foreach b $blocks { - set w($idx) [width $b] ;#we need the width of a rendered block for per-row renderline calls or padding - #set c($idx) [tcl::string::repeat " " [set w($idx)]] - #fairly commonly a block may be a vertical list of chars e.g something like 1\n2\n3 or -\n-\n-\n- - #for determining a shortcut to avoid unnecessary ta::detect - (e.g width <=1) we can't use result of textblock::width as it strips ansi. - #testing of any decent size block line by line - even with max_string_length_line is slower than ta::detect anyway. - if {[punk::ansi::ta::detect $b]} { - lappend fordata "v($idx)" [punk::lib::lines_as_list -ansireplays 1 -ansiresets $ansiresets -- $b] - } else { - #each block is being rendered into its own empty column - we don't need resets if it has no ansi, even if blocks to left and right do have ansi - lappend fordata "v($idx)" [split $b \n] - } - lappend colindices $idx - incr idx - } - set outlines [list] - #set colindices [lsort -integer -increasing [array names c]] - foreach {*}$fordata { - set row "" - foreach colidx $colindices { - #we know we have a single line, no ansi in underlay and no overflow required - so we can use renderline directly - #append row [overtype::renderline -width $w($colidx) -insert_mode 0 -info 0 $c($colidx) $v($colidx)] - append row [textblock::pad $v($colidx) -width $w($colidx) -which right -padchar " "] - } - lappend outlines $row - } - #puts stderr "--->outlines len: [llength $outlines]" - return [::join $outlines \n] - } - - proc ::textblock::trim {block} { - error "textblock::trim unimplemented" - set trimlines "" - } - - #pipealias ::textblock::join_right .= {list $lhs [tcl::string::repeat " " [width $lhs]] $rhs [tcl::string::repeat " " [width $rhs]]} {| - # /2,col1/1,col2/3 - # >} .=> punk::lib::lines_as_list -- {| - # data2 - # >} .=lhs> punk::lib::lines_as_list -- {| - # >} .= {lmap v $data w $data2 {val "[overtype::right $col1 $v][overtype::right $col2 $w]"}} {| - # >} punk::lib::list_as_lines punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a] - set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks] - set testblock [textblock::testblock 15 rainbow] - set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks] - set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents] - } - - - proc example {args} { - set opts [tcl::dict::create -forcecolour 0] - foreach {k v} $args { - switch -- $k { - -forcecolour { - tcl::dict::set opts $k $v - } - default { - error "textblock::example unrecognised option '$k'. Known-options: [tcl::dict::keys $opts]" - } - } - } - set opt_forcecolour 0 - if {[tcl::dict::get $opts -forcecolour]} { - set fc forcecolour - set opt_forcecolour 1 - } else { - set fc "" - } - set pleft [>punk . rhs] - set pright [>punk . lhs] - set prightair [>punk . lhs_air] - set red [a+ {*}$fc red]; set redb [a+ {*}$fc red bold] - set green [a+ {*}$fc green]; set greenb [a+ {*}$fc green bold] - set cyan [a+ {*}$fc cyan];set cyanb [a+ {*}$fc cyan bold] - set blue [a+ {*}$fc blue];set blueb [a+ {*}$fc blue bold] - set RST [a] - set gr0 [punk::ansi::g0 abcdefghijklm\nnopqrstuvwxyz] - set punks [textblock::join -- $pleft $pright] - set pleft_greenb $greenb$pleft$RST - set pright_redb $redb$pright$RST - set prightair_cyanb $cyanb$prightair$RST - set cpunks [textblock::join -- $pleft_greenb $pright_redb] - set out "" - append out $punks \n - append out $cpunks \n - append out [textblock::join -- $punks $cpunks] \n - set 2frames_a [textblock::join -- [textblock::frame -checkargs 0 $cpunks] [textblock::frame -checkargs 0 $punks]] - append out $2frames_a \n - set 2frames_b [textblock::join -- [textblock::frame -checkargs 0 -ansiborder $cyanb -title "plainpunks" $punks] [textblock::frame -checkargs 0 -ansiborder $greenb -title "fancypunks" $cpunks]] - append out [textblock::frame -checkargs 0 -title "punks" $2frames_b\n$RST$2frames_a] \n - set punkdeck [overtype::right [overtype::left [textblock::frame -checkargs 0 -ansiborder [a+ green bold] -type heavy -title ${redb}PATTERN$RST -subtitle ${redb}PUNK$RST $prightair_cyanb] "$blueb\n\n\P\nU\nN\nK$RST"] "$blueb\n\nD\nE\nC\nK"] - set spantable [[spantest] print] - append out [textblock::join -- $punkdeck " " $spantable] \n - #append out [textblock::frame -title gr $gr0] - append out [textblock::periodic -forcecolour $opt_forcecolour] - return $out - } - - 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 " | "]] - } - 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]\ - " "\ - $text\ - [>punk . rhs]\ - [punk::lib::list_as_lines -- [lrepeat 8 " | "]] - } - proc table {args} { - #todo - use punk::args - upvar ::textblock::class::opts_table_defaults toptdefaults - set defaults [tcl::dict::create\ - -rows [list]\ - -headers [list]\ - -return string\ - ] - - - set defaults [tcl::dict::merge $defaults $toptdefaults] ;# -title -frametype -show_header etc - set opts [tcl::dict::merge $defaults $args] - # -- --- --- --- - set opt_return [tcl::dict::get $opts -return] - set opt_rows [tcl::dict::get $opts -rows] - set opt_headers [tcl::dict::get $opts -headers] - # -- --- --- --- - set topts [tcl::dict::create] - set toptkeys [tcl::dict::keys $toptdefaults] - tcl::dict::for {k v} $opts { - if {$k in $toptkeys} { - tcl::dict::set topts $k $v - } - } - set t [textblock::class::table new {*}$topts] - - foreach h $opt_headers { - $t add_column -headers [list $h] - } - if {[$t column_count] == 0} { - if {[llength $opt_rows]} { - set r0 [lindex $opt_rows 0] - foreach c $r0 { - $t add_column - } - } - } - foreach r $opt_rows { - $t add_row $r - } - - - - if {$opt_return eq "string"} { - set result [$t print] - $t destroy - return $result - } else { - return $t - } - } - - proc frametype {f} { - #set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] - switch -- $f { - light - light_b - light_c - heavy - heavy_b - heavy_c - arc - arc_b - arc_c - double - block - block1 - block2 - block2hack - 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 { - all - hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} - hltj - hlbj - vllj - vlrj { - #also allow extra join arguments - } - default { - #k not in custom_keys - set is_custom_dict_ok 0 - break - } - } - } - } else { - set is_custom_dict_ok 0 - } - if {!$is_custom_dict_ok} { - error "frame option -type must be one of known types: $::textblock::frametypes or a dictionary with any of keys all,hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" - } - if {[dict exists $f all]} { - return [tcl::dict::create category custom type $f] - } else { - 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] - } - } - } - } - variable framedef_cache [tcl::dict::create] - 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 $args - if {[tcl::dict::exists $framedef_cache $cache_key]} { - return [tcl::dict::get $framedef_cache $cache_key] - } - - - #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\ - ] - set bad_option 0 - set values [list] - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - set a2 [tcl::prefix match -error "" {-- -joins -boxonly} $a] - switch -- $a2 { - -joins - -boxonly { - tcl::dict::set opts $a2 [lindex $args [incr i]] - } - -- { - set values [lrange $args $i+1 end] - break - } - default { - if {[string match -* $a]} { - set bad_option 1 - } else { - set values [lrange $args $i end] - } - break - } - } - } - set f [lindex $values 0] - set rawglobs [lrange $values 1 end] - if {![llength $rawglobs] || "all" in $rawglobs || "*" in $rawglobs} { - set globs * - } else { - set globs [list] - foreach g $rawglobs { - switch -- $g { - hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc - - hltj - hlbj - vllj - vlrj { - lappend globs $g - } - corner - corners { - lappend globs tlc blc trc brc - } - noncorner - noncorners { - #same as verticals + horizontals - lappend globs hl* vl* - } - vertical - verticals { - #we don't consider the corners part of this - lappend globs vl* - } - horizontal - horizontals { - lappend globs hl* - } - top - tops { - lappend globs tlc trc hlt* - } - bottom - bottoms { - lappend globs blc brc hlb* - } - left - lefts - lhs { - lappend globs tlc blc vll* - } - right - rights - rhs { - lappend globs trc brc vlr* - } - default { - #must look like a glob search if not one of the above - if {[regexp {[*?\[\]]} $g]} { - lappend globs $g - } else { - set bad_option 1 - } - } - } - } - } - if {$bad_option || [llength $values] == 0} { - #no framedef supplied, or unrecognised opt seen - set spec [string map [list $::textblock::frametypes] { - @id -id ::textblock::framedef - @cmd -name textblock::framedef\ - -help "Return a dict of the elements that make up a frame border. - May return a subset of available elements based on memberglob values." - - -joins -default "" -type list\ - -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 -type boolean\ - -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 - frametype -choices "" -choiceprefix 0 -choicerestricted 0 -type dict\ - -help "name from the predefined frametypes or an adhoc dictionary." - memberglob -type globstring -optional 1 -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices { - corner noncorner top bottom vertical horizontal left right - hl hlt hlb vsl vll vlr tlc trc blc brc hltj hlbj vllj vlrj - }\ - -help "restrict to keys matching memberglob." - }] - #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] - - - #sorted order down left right up - #1 x choose 4 - #4 x choose 3 - #6 x choose 2 - #4 x choose 1 - #15 combos - - set join_directions [list] - #targets - light,heavy (double?) - seem to be some required glyphs missing from unicode - #e.g down-light, up-heavy - set join_targets [tcl::dict::create left "" down "" right "" up ""] - foreach jt $joins { - lassign [split $jt -] direction target - if {$target ne ""} { - tcl::dict::set join_targets $direction $target - } - lappend join_directions $direction - } - set join_directions [lsort -unique $join_directions] - set do_joins [::join $join_directions _] - - - switch -- $f { - "altg" { - #old style ansi escape sequences with alternate graphics page G0 - set hl [cd::hl] - set hlt $hl - set hlb $hl - set vl [cd::vl] - set vll $vl - set vlr $vl - set tlc [cd::tlc] - set trc [cd::trc] - set blc [cd::blc] - set brc [cd::brc] - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - #No join targets available to join altg to other box styles - switch -- $do_joins { - down { - #1 - set blc [punk::ansi::g0 t] ;#(ltj) - set brc [punk::ansi::g0 u] ;#(rtj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } left { - #2 - set tlc [punk::ansi::g0 w] ;#(ttj) - set blc [punk::ansi::g0 v] ;#(btj) - set vllj [punk::ansi::g0 u] ;#(rtj) - } - right { - #3 - set trc [punk::ansi::g0 w] ;#(ttj) - set brc [punk::ansi::g0 v] ;#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - up { - #4 - set tlc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 u] ;#(rtj) - set hltj [punk::ansi::g0 v];#(btj) - } - down_left { - #5 - set blc [punk::ansi::g0 n] ;#(fwj) - set tlc [punk::ansi::g0 w] ;#(ttj) - set brc [punk::ansi::g0 u] ;#(rtj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - set vllj [punk::ansi::g0 u] ;#(rtj) - } - down_right { - #6 - set blc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 w] ;#(ttj) - set brc [punk::ansi::g0 n] ;#(fwj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - down_up { - #7 - set blc [punk::ansi::g0 t] ;#(ltj) - set brc [punk::ansi::g0 u] ;#(rtj) - - set tlc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 u] ;#(rtj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - set hltj [punk::ansi::g0 v];#(btj) - } - left_right { - #8 - #from 2 - set tlc [punk::ansi::g0 w] ;#(ttj) - set blc [punk::ansi::g0 v] ;#(btj) - #from3 - set trc [punk::ansi::g0 w] ;#(ttj) - set brc [punk::ansi::g0 v] ;#(btj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - left_up { - #9 - set tlc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 u] ;#(rtj) - set blc [punk::ansi::g0 v] ;#(btj) - set vllj [punk::ansi::g0 u] ;#(rtj) - } - right_up { - #10 - set tlc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 n] ;#(fwj) - set brc [punk::ansi::g0 v] ;#(btj) - set hltj [punk::ansi::g0 v];#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - down_left_right { - #11 - set blc [punk::ansi::g0 n] ;#(fwj) - set brc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 w] ;#(ttj) - set tlc [punk::ansi::g0 w] ;#(ttj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } - down_left_up { - #12 - set tlc [punk::ansi::g0 n] ;#(fwj) - set blc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 u] ;#(rtj) - set brc [punk::ansi::g0 u] ;#(rtj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set hltj [punk::ansi::g0 v];#(btj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } - down_right_up { - #13 - set tlc [punk::ansi::g0 t] ;#(ltj) - set blc [punk::ansi::g0 t] ;#(ltj) - set trc [punk::ansi::g0 n] ;#(fwj) - set brc [punk::ansi::g0 n] ;#(fwj) - set hltj [punk::ansi::g0 v];#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } - left_right_up { - #14 - set tlc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 n] ;#(fwj) - set blc [punk::ansi::g0 v] ;#(btj) - set brc [punk::ansi::g0 v] ;#(btj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set hltj [punk::ansi::g0 v];#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - } - down_left_right_up { - #15 - set tlc [punk::ansi::g0 n] ;#(fwj) - set blc [punk::ansi::g0 n] ;#(fwj) - set trc [punk::ansi::g0 n] ;#(fwj) - set brc [punk::ansi::g0 n] ;#(fwj) - set vllj [punk::ansi::g0 u] ;#(rtj) - set hltj [punk::ansi::g0 v];#(btj) - set vlrj [punk::ansi::g0 t] ;#(ltj) - set hlbj [punk::ansi::g0 w] ;#(ttj) - } - } - - - } - "ascii" { - set hl - - set hlt - - set hlb - - set vl | - set vll | - set vlr | - set tlc + - set trc + - set blc + - set brc + - #horizontal and vertical bar joins - #set hltj $hlt - #set hlbj $hlb - #set vllj $vll - #set vlrj $vlr - #ascii + is small - can reasonably be considered a join to anything? - set hltj + - set hlbj + - set vllj + - set vlrj + - #our corners are all + already - so we won't do anything for directions or targets - - } - "light" { - #unicode box drawing set - set hl [punk::char::charshort boxd_lhz] ;# light horizontal - set hlt $hl - set hlb $hl - set vl [punk::char::charshort boxd_lv] ;#light vertical - set vll $vl - set vlr $vl - set tlc [punk::char::charshort boxd_ldr] - set trc [punk::char::charshort boxd_ldl] - set blc [punk::char::charshort boxd_lur] - set brc [punk::char::charshort boxd_lul] - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - #15 combos - #sort order: down left right up - #ltj,rtj,ttj,btj e.g left T junction etc. - #Look at from the perspective of a frame/table outline with a clean border and arms pointing inwards - - #set targetdown,targetleft,targetright,targetup vars - #default empty targets to current box type 'light' - foreach dir {down left right up} { - set rawtarget [tcl::dict::get $join_targets $dir] - lassign [split $rawtarget _] target ;# treat variants light light_b lightc the same - switch -- $target { - "" - light { - set target$dir light - } - ascii - altg - arc { - set target$dir light - } - heavy { - set target$dir $target - } - default { - set target$dir other - } - } - } - switch -- $do_joins { - down { - #1 - switch -- $targetdown { - heavy { - set blc [punk::char::charshort boxd_dhrul] ;#\u251f down hieavy and right up light (ltj) - set brc \u2527 ;#boxd_dhlul down heavy and left up light (rtj) - set hlbj \u2530 ;# down heavy (ttj) - } - light { - set blc \u251c ;#[punk::char::charshort boxd_lvr] light vertical and right (ltj) - set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - set hlbj \u252c ;# (ttj) - } - } - } - left { - #2 - switch -- $targetleft { - heavy { - set tlc \u252d ;# Left Heavy and Right Down Light (ttj) - set blc \u2535 ;# Left Heavy and Right Up Light (btj) - set vllj \u2525 ;# left heavy (rtj) - } - light { - set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - joinleft - set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - set vllj \u2524 ;# (rtj) - } - } - } - right { - #3 - switch -- $targetright { - heavy { - set trc \u252e ;#Right Heavy and Left Down Light (ttj) - set brc \u2536 ;#Right Heavy and Left up Light (btj) - set vlrj \u251d;#right heavy (ltj) - } - light { - set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - set vlrj \u251c;# (ltj) - } - } - } - up { - #4 - switch -- $targetup { - heavy { - set tlc \u251e ;#up heavy (ltj) - set trc \u2526 ;#up heavy (rtj) - } - light { - set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - } - } - } - down_left { - #5 - switch -- $targetdown-$targetleft { - other-light { - set blc \u2534 ;#(btj) - set tlc \u252c ;#(ttj) - #brc - default corner - set vllj \u2524 ;# (rtj) - } - other-other { - #default corners - } - other-heavy { - set blc \u2535 ;# heavy left (btj) - set tlc \u252d ;#heavy left (ttj) - #brc default corner - set vllj \u2525 ;# heavy left (rtj) - } - heavy-light { - set blc \u2541 ;# heavy down (fwj) - set tlc \u252c ;# light (ttj) - set brc \u2527 ;# heavy down (rtj) - set vllj \u2524 ;# (rtj) - set hlbj \u2530 ;# heavy down (ttj) - } - heavy-other { - set blc \u251f ;#heavy down (ltj) - #tlc - default corner - set brc \u2527 ;#heavy down (rtj) - set hlbj \u2530 ;# heavy down (ttj) - } - heavy-heavy { - set blc \u2545 ;#heavy down and left (fwj) - set tlc \u252d ;#heavy left (ttj) - set brc \u2527 ;#heavy down (rtj) - set vllj \u2525 ;# heavy left (rtj) - set hlbj \u2530 ;# heavy down (ttj) - } - light-light { - set blc \u253c ;# [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set tlc \u252c ;# boxd_ldhz (ttj) - set brc \u2524 ;# boxd_lvl light vertical and left(rtj) - set vllj \u2524 ;# (rtj) - set hlbj \u252c ;# (ttj) - } - light-other { - set blc \u251c ;# (ltj) - #tlc - default corner - set brc \u2524 ;# boxd_lvl (rtj) - set hlbj \u252c ;# (ttj) - } - light-heavy { - set blc \u253d ;# heavy left (fwj) - set tlc \u252d ;# heavy left (ttj) - set brc \u2524 ;# light (rtj) - set vllj \u2525 ;# heavy left (rtj) - set hlbj \u252c ;# (ttj) - } - default { - set blc \u253c ;# [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set tlc \u252c ;# [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set brc \u2524 ;# [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - } - } - } - down_right { - #6 - set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - } - down_up { - #7 - set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - - set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - } - left_right { - #8 - #from 2 - set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - joinleft - set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - #from3 - set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - - - switch -- $targetleft-$targetright { - heavy-light { - set tlc \u252d ;# Left Heavy and Right Down Light (ttj) - set blc \u2535 ;# Left Heavy and Right Up Light (btj) - set vllj \u2525 ;# left heavy (rtj) - set vlrj \u251c;#right light (ltj) - } - heavy-other { - set tlc \u252d ;# Left Heavy and Right Down Light (ttj) - set blc \u2535 ;# Left Heavy and Right Up Light (btj) - set vllj \u2525 ;# left heavy (rtj) - } - heavy-heavy { - set vllj \u2525 ;# left heavy (rtj) - set vlrj \u251d;#right heavy (ltj) - set tlc \u252d ;# Left Heavy and Right Down Light (ttj) - set blc \u2535 ;# Left Heavy and Right Up Light (btj) - set trc \u252e ;#Right Heavy and Left Down Light (ttj) - set brc \u2536 ;#Right Heavy and Left up Light (btj) - } - light-heavy { - set trc \u252e ;#Right Heavy and Left Down Light (ttj) - set brc \u2536 ;#Right Heavy and Left up Light (btj) - set vlrj \u251d;#right heavy (ltj) - set vllj \u2524 ;# left light (rtj) - } - light-other { - set vllj \u2524 ;# left light (rtj) - } - light-light { - set vllj \u2524 ;# left light (rtj) - set vlrj \u251c;#right light (ltj) - } - } - #set vllj \u2525 ;# left heavy (rtj) - #set vllj \u2524 ;# left light (rtj) - #set vlrj \u251d;#right heavy (ltj) - #set vlrj \u251c;#right light (ltj) - } - left_up { - #9 - set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - } - right_up { - #10 - set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - } - down_left_right { - #11 - set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - set tlc [punk::char::charshort boxd_ldhz] ;#T shape (ttj) - - } - down_left_up { - #12 - set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - set brc [punk::char::charshort boxd_lvl] ;#light vertical and left (rtj) - - } - down_right_up { - #13 - set tlc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set blc [punk::char::charshort boxd_lvr] ;#light vertical and right (ltj) - set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - } - left_right_up { - #14 - set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set blc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - set brc [punk::char::charshort boxd_luhz] ;#upside down T shape (btj) - - } - down_left_right_up { - #15 - set tlc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set blc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set trc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - set brc [punk::char::charshort boxd_lvhz] ;#light vertical and horizontal (fwj) - } - } - #four way junction (cd::fwj) (punk::ansi::g0 n) (punk::char::charshort lvhz) (+) - } - light_b { - set hl " " - set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner vll vlr vllj vlrj] - tcl::dict::with arcframe {} ;#extract keys as vars - } - light_c { - set hl " " - set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner] - tcl::dict::with arcframe {} ;#extract keys as vars - } - "heavy" { - #unicode box drawing set - set hl [punk::char::charshort boxd_hhz] ;# light horizontal - set hlt $hl - set hlb $hl - set vl [punk::char::charshort boxd_hv] ;#light vertical - set vll $vl - set vlr $vl - set tlc [punk::char::charshort boxd_hdr] - set trc [punk::char::charshort boxd_hdl] - set blc [punk::char::charshort boxd_hur] - set brc [punk::char::charshort boxd_hul] - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - #set targetdown,targetleft,targetright,targetup vars - #default empty targets to current box type 'heavy' - foreach dir {down left right up} { - set target [tcl::dict::get $join_targets $dir] - switch -- $target { - "" - heavy { - set target$dir heavy - } - light - ascii - altg - arc { - set target$dir light - } - default { - set target$dir other - } - } - } - switch -- $do_joins { - down { - #1 - switch -- $targetdown { - light { - set blc [punk::char::charshort boxd_dlruh] ;#\u2521 down light and right up heavy (ltj) - set brc [punk::char::charshort boxd_dlluh] ;#\u2529 down light and left up heavy (rtj) - set hlbj \u252F ;#down light (ttj) - } - heavy { - set blc [punk::char::charshort boxd_hvr] ;# (ltj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - set hlbj \u2533 ;# down heavy (ttj) - } - } - } - left { - #2 - switch -- $targetleft { - light { - set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) - set blc [punk::char::charshort boxd_llruh] ;#\u253a Left Light and Right Up Heavy (btj) - set vllj \u2528 ;# left light (rtj) - } - heavy { - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - set vllj \u252b ;#(rtj) - } - } - } - right { - #3 - switch -- $targetright { - light { - set trc [punk::char::charshort boxd_rlldh] ;#\u2531 Right Light and Left Down Heavy (ttj) - set brc [punk::char::charshort boxd_rlluh] ;#\u2539 Right Light and Left Up Heavy(btj) - set vlrj \u2520 ;#right light (ltj) - } - heavy { - set trc [punk::char::charshort boxd_hdhz] ;#T shape (ttj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - set vlrj \u2523 ;# (ltj) - } - } - } - up { - #4 - switch -- $targetup { - light { - set tlc [punk::char::charshort boxd_ulrdh] ;#\u2522 Up Light and Right Down Heavy (ltj) - set trc [punk::char::charshort boxd_ulldh] ;#\u252a Up Light and Left Down Heavy (rtj) - set hltj \u2537 ;# up light (btj) - } - heavy { - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set hltj \u253b ;# (btj) - } - } - } - down_left { - #down_left is the main join type used for 'L' shaped cell border table building where we boxlimit to {vll hlb blc} - #5 - switch -- down-$targetdown-left-$targetleft { - down-light-left-heavy { - set blc [punk::char::charshort boxd_dluhzh] ;#down light and up horizontal heavy (fwj) - set brc [punk::char::charshort boxd_dlluh] ;#\u2529 down light and left up heavy (rtj) - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) (at tlc down stays heavy) - set hlbj \u252F ;# down light (ttj) - set vllj \u252b ;#(rtj) - } - down-heavy-left-light { - set blc [punk::char::charshort boxd_llrvh] ;# left light and right Vertical Heavy (fwj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) (at brc left must stay heavy) - set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) - set hlbj \u2533 ;# down heavy (ttj) - set vllj \u2528 ;# left light (rtj) - } - down-light-left-light { - set blc [punk::char::charshort boxd_ruhldl] ;#\u2544 right up heavy and left down light (fwj) - set brc [punk::char::charshort boxd_dlluh] ;#\u2529 Down Light and left Up Heavy (rtj) (left must stay heavy) - set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) (we are in heavy - so down must stay heavy at tlc) - set hlbj \u252F ;# down light (ttj) - set vllj \u2528 ;# left light (rtj) - } - down-heavy-left-heavy { - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set hlbj \u2533 ;#(ttj) - set vllj \u252b ;#(rtj) - } - down-other-left-heavy { - set blc \u253b ;#boxd_huhz Heavy Up and Horizontal (btj) - #leave brc default corner - set tlc \u2533 ;#hdhz Heavy Down and Horizontal (ttj) - - set vllj \u252b ;#(rtj) - } - down-other-left-light { - set blc \u253a ;#llruh Left Light and Right Up Heavy (btj) - #leave brc default corner - set tlc \u2532 ;#llrdh Left Light and Right Down Heavy (ttj) - - set vllj \u2528 ;# left light (rtj) - } - down-heavy-left-other { - set blc \u2523 ;#hvr Heavy Vertical and Right (ltj) - set brc \u252b ;#hvl Heavy Veritcal and Left (rtj) - #leave tlc default corner - - set hlbj \u2533 ;#(ttj) - } - down-light-left-other { - set blc \u2521 ;#dlruh Down Light and Right Up Heavy (ltj) - set brc \u2529 ;#dlluh Down Light and Left Up Heavy (rtj) - #leave tlc default corner - - set hlbj \u252F ;# down light (ttj) - } - } - } - down_right { - #6 - set blc [punk::char::charshort boxd_hvr] ;# (ltj) (blc right&up stay heavy) - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) (tlc down&left stay heavy) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) (brc left&up heavy) - } - down_up { - #7 - set blc [punk::char::charshort boxd_hvr] ;# (ltj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - } - left_right { - #8 - #from 2 - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - #from3 - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - } - left_up { - #9 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - } - right_up { - #10 - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - } - down_left_right { - #11 - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hdhz] ;# (ttj) - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - - } - down_left_up { - #12 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvl] ;# (rtj) - set brc [punk::char::charshort boxd_hvl] ;# (rtj) - - } - down_right_up { - #13 - set tlc [punk::char::charshort boxd_hvr] ;# (ltj) - set blc [punk::char::charshort boxd_hvr] ;# (ltj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - } - left_right_up { - #14 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_huhz] ;# (btj) - set brc [punk::char::charshort boxd_huhz] ;# (btj) - - } - down_left_right_up { - #15 - set tlc [punk::char::charshort boxd_hvhz] ;# (fwj) - set blc [punk::char::charshort boxd_hvhz] ;# (fwj) - set trc [punk::char::charshort boxd_hvhz] ;# (fwj) - set brc [punk::char::charshort boxd_hvhz] ;# (fwj) - } - } - } - heavy_b { - set hl " " - set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner vll vlr vllj vlrj] - tcl::dict::with arcframe {} ;#extract keys as vars - } - heavy_c { - set hl " " - set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner] - tcl::dict::with arcframe {} ;#extract keys as vars - } - "double" { - #unicode box drawing set - set hl [punk::char::charshort boxd_dhz] ;# double horizontal \U2550 - set hlt $hl - set hlb $hl - set vl [punk::char::charshort boxd_dv] ;#double vertical \U2551 - set vll $vl - set vlr $vl - set tlc [punk::char::charshort boxd_ddr] ;#double down and right \U2554 - set trc [punk::char::charshort boxd_ddl] ;#double down and left \U2557 - set blc [punk::char::charshort boxd_dur] ;#double up and right \U255A - set brc [punk::char::charshort boxd_dul] ;#double up and left \U255D - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - # \u256c (fwj) - - #set targetdown,targetleft,targetright,targetup vars - #default empty targets to current box type 'double' - foreach dir {down left right up} { - set target [tcl::dict::get $join_targets $dir] - switch -- $target { - "" - double { - set target$dir double - } - light { - set target$dir light - } - default { - set target$dir other - } - } - } - - #unicode provides no joining for double to anything else - #better to leave a gap by using default double corners if join target is not empty or double - switch -- $do_joins { - down { - #1 - switch -- $targetdown { - double { - set blc \u2560 ;# (ltj) - set brc \u2563 ;# (rtj) - set hlbj \u2566 ;# (ttj) - } - light { - set hlbj \u2564 ;# down light (ttj) - } - } - } - left { - #2 - switch -- $targetleft { - double { - set tlc \u2566 ;# (ttj) - set blc \u2569 ;# (btj) - set vllj \u2563 ;# (rtj) - } - light { - set vllj \u2562 ;# light left (rtj) - } - } - } - right { - #3 - switch -- $targetright { - double { - set trc \u2566 ;# (ttj) - set brc \u2569 ;# (btj) - } - light { - set vlrj \u255F ;# light right (ltj) - } - } - } - up { - #4 - switch -- $targetup { - double { - set tlc \u2560 ;# (ltj) - set trc \u2563 ;# (rtj) - set hltj \u2569 ;# (btj) - } - light { - set hltj \u2567 ;#up light (btj) - } - } - } - down_left { - #5 - switch -- $targetdown-$targetleft { - double-double { - set blc \u256c ;# (fwj) - set brc \u2563 ;# (rtj) - set tlc \u2566 ;# (ttj) - set hlbj \u2566 ;# (ttj) - } - double-light { - #no corner joins treat corners like 'other' - set blc \u2560 ;# (ltj) - set brc \u2563 ;# (rtj) - - set hlbj \u2566 ;# (ttj) - set vllj \u2562 ;# light left (rtj) - - } - double-other { - set blc \u2560 ;# (ltj) - set brc \u2563 ;# (rtj) - #leave tlc as ordinary double corner - } - light-double { - - set vllj \u2563 ;# (rtj) - set hlbj \u2564 ;# light down (ttj) - - } - light-light { - - set vllj \u2562 ;# light left (rtj) - set hlbj \u2564 ;# light down (ttj) - } - other-light { - set vllj \u2562 ;# light left (rtj) - } - other-double { - set blc \u2569 ;# (btj) - #leave brc as ordinary double corner - set tlc \u2566 ;# (ttj) - } - } - } - down_right { - #6 - switch -- $targetdown-$targetright { - double-double { - set blc \u2560 ;# (ltj) - set trc \u2566 ;# (ttj) - set brc \u256c ;# (fwj) - set hlbj \u2566 ;# (ttj) - } - double-other { - set blc \u2560 ;# (ltj) - #leave trc default - set brc \u2563 ;# (rtj) - } - other-double { - #leave blc default - set trc \u2566 ;# (ttj) - set brc \u2569 ;#(btj) - } - } - } - down_up { - #7 - switch -- $targetdown-$targetup { - double-double { - set blc \u2560 ;# (ltj) - set brc \u2563 ;# (rtj) - set tlc \u2560 ;# (ltj) - set trc \u2563 ;# (rtj) - set hltj \u2569 ;# (btj) - set hlbj \u2566 ;# (ttj) - } - } - } - left_right { - #8 - - #from 2 - #set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) - set tlc \U2566 ;# (ttj) - #set blc [punk::char::charshort boxd_huhz] ;# (btj) - set blc \u2569 ;# (btj) - #from3 - set trc [punk::char::charshort boxd_ddhz] ;# (ttj) - set brc [punk::char::charshort boxd_duhz] ;# (btj) - } - left_up { - #9 - set tlc [punk::char::charshort boxd_dvhz] ;# (fwj) - set trc [punk::char::charshort boxd_dvl] ;# (rtj) - set blc [punk::char::charshort boxd_duhz] ;# (btj) - set hltj \u2569 ;# (btj) - set vllj \u2563 ;# (rtj) - } - right_up { - #10 - set tlc [punk::char::charshort boxd_dvr] ;# (ltj) - set trc [punk::char::charshort boxd_dvhz] ;# (fwj) - set brc [punk::char::charshort boxd_duhz] ;# (btj) - set hltj \u2569 ;# (btj) - set vlrj \u2560 ;# (ltj) - } - down_left_right { - #11 - set blc [punk::char::charshort boxd_dvhz] ;# (fwj) - set brc [punk::char::charshort boxd_dvhz] ;# (fwj) - set trc [punk::char::charshort boxd_ddhz] ;# (ttj) - set tlc [punk::char::charshort boxd_ddhz] ;# (ttj) - set hlbj \u2566 ;# (ttj) - set vlrj \u2560 ;# (ltj) - - } - down_left_up { - #12 - set tlc [punk::char::charshort boxd_dvhz] ;# (fwj) - set blc [punk::char::charshort boxd_dvhz] ;# (fwj) - set trc [punk::char::charshort boxd_dvl] ;# (rtj) - set brc [punk::char::charshort boxd_dvl] ;# (rtj) - set hltj \u2569 ;# (btj) - set hlbj \u2566 ;# (ttj) - - } - down_right_up { - #13 - set tlc [punk::char::charshort boxd_dvr] ;# (ltj) - set blc [punk::char::charshort boxd_dvr] ;# (ltj) - set trc [punk::char::charshort boxd_dvhz] ;# (fwj) - set brc [punk::char::charshort boxd_dvhz] ;# (fwj) - set hltj \u2569 ;# (btj) - set hlbj \u2566 ;# (ttj) - } - left_right_up { - #14 - set tlc [punk::char::charshort boxd_dvhz] ;# (fwj) - set trc [punk::char::charshort boxd_dvhz] ;# (fwj) - set blc [punk::char::charshort boxd_duhz] ;# (btj) - set brc [punk::char::charshort boxd_duhz] ;# (btj) - set hltj \u2569 ;# (btj) - - } - down_left_right_up { - #15 - set tlc [punk::char::charshort boxd_dvhz] ;# (fwj) - set blc [punk::char::charshort boxd_dvhz] ;# (fwj) - set trc [punk::char::charshort boxd_dvhz] ;# (fwj) - set brc [punk::char::charshort boxd_dvhz] ;# (fwj) - set hltj \u2569 ;# (btj) - set hlbj \u2566 ;# (ttj) - } - } - - } - "arc" { - #unicode box drawing set - - - set hl [punk::char::charshort boxd_lhz] ;# light horizontal - set hlt $hl - set hlb $hl - set vl [punk::char::charshort boxd_lv] ;#light vertical - set vll $vl - set vlr $vl - set tlc [punk::char::charshort boxd_ladr] ;#light arc down and right \U256D - set trc [punk::char::charshort boxd_ladl] ;#light arc down and left \U256E - set blc [punk::char::charshort boxd_laur] ;#light arc up and right \U2570 - set brc [punk::char::charshort boxd_laul] ;#light arc up and left \U256F - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - #set targetdown,targetleft,targetright,targetup vars - #default empty targets to current box type 'arc' - foreach dir {down left right up} { - set target [tcl::dict::get $join_targets $dir] - switch -- $target { - "" - arc { - set target$dir self - } - default { - set target$dir other - } - } - } - - switch -- $do_joins { - down { - #1 - switch -- $targetdown { - self { - set blc \u251c ;# *light (ltj) - #set blc \u29FD ;# misc math right-pointing curved angle bracket (ltj) - positioned too far left - #set blc \u227b ;# math succeeds char. joins on right ok - gaps top and bottom - almost passable - #set blc \u22b1 ;#math succeeds under relation - looks 'ornate', sits too low to join horizontal - - #set brc \u2524 ;# *light(rtj) - #set brc \u29FC ;# misc math left-pointing curved angle bracket (rtj) - } - } - } - left { - #2 - switch -- $targetleft { - self { - set tlc \u252c ;# *light(ttj) - need a low positioned curved y shape - nothing apparent - #set blc \u2144 ;# (btj) - upside down y - positioning too low for arc - set blc \u2534 ;# *light (btj) - } - } - } - right { - #3 - switch -- $targetright { - self { - set trc \u252c ;# *light (ttj) - #set brc \u2144 ;# (btj) - set brc \u2534 ;# *light (btj) - } - } - } - up { - #4 - switch -- $targetup { - self { - set tlc \u251c ;# *light (ltj) - set trc \u2524 ;# *light(rtj) - } - } - } - down_left { - #5 - switch -- $targetdown-$targetleft { - self-self { - #set blc \u27e1 ;# white concave-sided diamond - positioned too far right - #set blc \u27e3 ;# concave sided diamond with rightwards tick - positioned too low, too right - big gaps - #set blc \u2bce ;# from "Miscellaneous Symbols and Arrows" - positioned too far right - set brc \u2524 ;# *light (rtj) - set tlc \u252c ;# *light (ttj) - } - self-other { - #set blc \u2560 ;# (ltj) - #set brc \u2563 ;# (rtj) - #leave tlc as ordinary double corner - } - other-self { - #set blc \u2569 ;# (btj) - #leave brc as ordinary double corner - #set tlc \u2566 ;# (ttj) - } - } - } - down_right { - switch -- $targetdown-$targetright { - self-self { - #set brc \u2bce ;# from "Miscellaneous Symbols and Arrows" - positioned too far right - set trc \u252c ;# (ttj) - set blc \u2524 ;# (rtj) - } - } - } - } - } - arc_b { - set hl " " - set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner vll vlr vllj vlrj] - tcl::dict::with arcframe {} ;#extract keys as vars - } - arc_c { - set hl " " - set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner] - tcl::dict::with arcframe {} ;#extract keys as vars - } - 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 - set vlr \u2595 ;# right one eighth block - set tlc \u2581 ;# lower one eighth block - set trc \u2581 ;# lower one eighth block - set blc \u2594 ;# upper one eighth block - set brc \u2594 ;# upper one eight block - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - } - 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 vlr \u2595 ;# right one eighth block - set vll \u258f ;# left one eighth block - - #some terminals (on windows as at 2024) miscount width of these single-width blocks internally - #resulting in extra spacing that is sometimes well removed from the character itself (e.g at next ansi reset) - #This was fixed in windows-terminal based systems (2021) but persists in others. - #https://github.com/microsoft/terminal/issues/11694 - set tlc \U1fb7d ;#legacy block - set trc \U1fb7e ;#legacy block - set blc \U1fb7c ;#legacy block - set brc \U1fb7f ;#legacy block - - if {[punk::console::check::has_bug_legacysymbolwidth]} { - #rather than totally fail on some mixed layout that happens to use block2 - just degrade it - but prevent alignment problems - set sp \u00a0 ;#non breaking space (plain space may act transparent in some use cases) - set tlc $sp - set trc $sp - set blc $sp - set brc $sp - } - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - - } - block2hack { - #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 vlr \u2595 ;# right one eighth block - set vll \u258f ;# left one eighth block - - #see comments in block2 regarding the problems in some terminals that this *may* hack around to some extent. - #the caller probably only needs block2hack if block2 doesn't work - - #1) - #review - this hack looks sort of promising - but overtype::renderline needs fixing ? - #set tlc \U1fb7d\b ;#legacy block - #set trc \U1fb7e\b ;#legacy block - #set blc \U1fb7c\b ;#legacy block - #set brc \U1fb7f\b ;#legacy block - - #2) - works on cmd.exe and some others - # a 'privacy message' is 'probably' also not supported on the old terminal but is on newer ones - #known exception - conemu on windows - displays junk for various ansi codes - (and slow terminal anyway) - #this hack has a reasonable chance of working - #except that the punk overtype library does recognise PMs - #A single backspace however is an unlikely and generally unuseful PM - so there is a corresponding hack in the renderline system to pass this PM through! - #ugly - in that we don't know the application specifics of what the PM data contains and where it's going. - set tlc \U1fb7d\x1b^\b\x1b\\ ;#legacy block - set trc \U1fb7e\x1b^\b\x1b\\ ;#legacy block - set blc \U1fb7c\x1b^\b\x1b\\ ;#legacy block - set brc \U1fb7f\x1b^\b\x1b\\ ;#legacy block - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - } - block { - set hlt \u2580 ;#upper half - set hlb \u2584 ;#lower half - set vll \u258c ;#left half - set vlr \u2590 ;#right half - - set tlc \u259b ;#upper left corner half - set trc \u259c - set blc \u2599 - set brc \u259f - - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr - } - default { - #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 - set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] - if {"all" in [dict keys $f]} { - set A [dict get $f all] - set default_custom [tcl::dict::create hl $A vl $A tlc $A trc $A blc $A brc $A] - } - if {[llength $f] % 2} { - #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" - } - #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 { - all - hl - vl - tlc - trc - blc - brc - hlt - hlb - vll - vlr - hltj - hlbj - vllj - vlrj {} - default { - error "textblock::frametype '$f' has unknown element '$k'" - } - } - } - #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]] - } - } - #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} { - set result [tcl::dict::create\ - tlc $tlc hlt $hlt trc $trc\ - vll $vll vlr $vlr\ - blc $blc hlb $hlb brc $brc\ - ] - } else { - set result [tcl::dict::create\ - tlc $tlc hlt $hlt trc $trc\ - vll $vll vlr $vlr\ - blc $blc hlb $hlb brc $brc\ - hltj $hltj\ - hlbj $hlbj\ - vllj $vllj\ - vlrj $vlrj\ - ] - } - set result [dict filter $result key {*}$globs] - tcl::dict::set framedef_cache $cache_key $result - return $result - } - - - variable frame_cache - set frame_cache [tcl::dict::create] - - punk::args::definition { - @id -id ::textblock::frame_cache - @cmd -name textblock::frame_cache -help\ - "Display or clear the frame cache." - -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 - } - proc frame_cache {args} { - set argd [punk::args::get_by_id ::textblock::frame_cache $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 - 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 - } - 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] - append out \nCLEARED - } - return $out - } - - - variable FRAMETYPES - set FRAMETYPES [textblock::frametypes] - variable EG - set EG [a+ brightblack] - variable RST - set RST [a] - - proc frame_samples {} { - set FRAMETYPELABELS [dict create] - if {[info commands ::textblock::frame] ne ""} { - foreach ft [frametypes] { - dict set FRAMETYPELABELS $ft [textblock::frame -checkargs 0 -type $ft " "] - } - } - set FRAMETYPELABELS [dict remove $FRAMETYPELABELS block2hack] - return $FRAMETYPELABELS - } - #proc EG {} "return {[a+ brightblack]}" - #make EG fetch from SGR cache so as to abide by colour off/on - proc EG {} { - a+ brightblack - } - #proc RST {} "return {\x1b\[m}" - proc RST {} { - return "\x1b\[m" - } - - #catch 22 for -choicelabels - need some sort of lazy evaluation - # ${[textblock::frame_samples]} - - #todo punk::args alias for centre center etc? - punk::args::definition -dynamic 1 { - @id -id ::textblock::frame - @cmd -name "textblock::frame"\ - -help "Frame a block of text with a border." - -checkargs -default 1 -type boolean\ - -help "If true do extra argument checks and - provide more comprehensive error info. - Set false for slight performance improvement." - -etabs -default 0\ - -help "expanding tabs - experimental/unimplemented." - -type -default light -choices {${[textblock::frametypes]}} -choicerestricted 0 -choicecolumns 8 -type dict\ - -choicelabels { - ${[textblock::frame_samples]} - }\ - -help "Type of border for frame." - -boxlimits -default {hl vl tlc blc trc brc} -type list -help "Limit the border box to listed elements. - passing an empty string will result in no box, but title/subtitle will still appear if supplied. - ${[textblock::EG]}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${[textblock::RST]}" - -boxmap -default {} -type dict - -joins -default {} -type list - -title -default "" -type string -regexprefail {\n}\ - -help "Frame title placed on topbar - no newlines. - May contain ANSI - no trailing reset required. - ${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing - e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}" - -subtitle -default "" -type string -regexprefail {\n}\ - -help "Frame subtitle placed on bottombar - no newlines - May contain Ansi - no trailing reset required." - -width -default "" -type int\ - -help "Width of resulting frame including borders. - If omitted or empty-string, the width will be determined automatically based on content." - -height -default "" -type int\ - -help "Height of resulting frame including borders." - -ansiborder -default "" -type ansistring\ - -help "Ansi escape sequence to set border attributes. - ${[textblock::EG]}e.g 1: frame -ansiborder [a+ web-red] contents - e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${[textblock::RST]}" - -ansibase -default "" -type ansistring\ - -help "Default ANSI attributes within frame." - -blockalign -default centre -choices {left right centre}\ - -help "Alignment of the content block within the frame." - -pad -default 1 -type boolean -help "Whether to pad within the ANSI so content background - extends within the content block inside the frame. - Has no effect if no ANSI in content." - -textalign -default left -choices {left right centre}\ - -help "Alignment of text within the content block. (centre unimplemented)" - -ellipsis -default 1 -type boolean\ - -help "Whether to show elipsis for truncated content and title/subtitle." - -usecache -default 1 -type boolean - -buildcache -default 1 -type boolean - -crm_mode -default 0 -type boolean\ - -help "Show ANSI control characters within frame contents. - (Control Representation Mode) - Frame width doesn't adapt and content may be truncated - so -width may need to be manually set to display more." - - @values -min 0 -max 1 - contents -default "" -type string\ - -help "Frame contents - may be a block of text containing newlines and ANSI. - Text may be 'ragged' - ie unequal line-lengths. - No trailing ANSI reset required. - ${[textblock::EG]}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${[textblock::RST]}" - } - - #options before content argument - which is allowed to be absent - #frame performance (noticeable with complex tables even of modest size) is improved somewhat by frame_cache - but is still (2024) a fairly expensive operation. - # - #consider if we can use -sticky nsew instead of -blockalign (as per Tk grid -sticky option) - # This would require some sort of expand equivalent e.g for -sticky ew or -sticky ns - for which we have to decide a meaning for text.. e.g ansi padding? - #We are framing 'rendered' text - so we don't have access to for example an inner frame or table to tell it to expand - #we could refactor as an object and provide a -return object option, then use stored -sticky data to influence how another object renders into it - # - but we would need to maintain support for the rendered-string based operations too. - proc frame {args} { - variable frametypes - variable use_hash - - #counterintuitively - in-proc dict create each time is generally slightly faster than linked namespace var - set opts [tcl::dict::create\ - -etabs 0\ - -type light\ - -boxlimits [list hl vl tlc blc trc brc]\ - -boxmap {}\ - -joins [list]\ - -title ""\ - -subtitle ""\ - -width ""\ - -height ""\ - -ansiborder ""\ - -ansibase ""\ - -blockalign "centre"\ - -textalign "left"\ - -ellipsis 1\ - -usecache 1\ - -buildcache 1\ - -pad 1\ - -crm_mode 0\ - -checkargs 1\ - ] - #-pad 1 is default so that simple 'textblock::frame "[a+ Red]a \nbbb[a]" extends the bg colour on the short ragged lines (and empty lines) - # for ansi art - -pad 0 is likely to be preferable - - set has_contents 0 - set optlist $args ;#initial only - content will be removed - #no solo opts for frame - if {[llength $args] %2 == 0} { - if {[lindex $args end-1] eq "--"} { - set contents [lpop optlist end] - set has_contents 1 - lpop optlist end ;#drop the end-of-opts flag - } else { - set optlist $args - set contents "" - } - } else { - set contents [lpop optlist end] - set has_contents 1 - } - - #todo args -justify left|centre|right (center) - #todo -blockalignbias -textalignbias? - #use -buildcache 1 with -usecache 0 for debugging cache issues so we can inspect using textblock::frame_cache - set optnames [tcl::dict::keys $opts] - set opts_ok 1 ;#default assumption - foreach {k v} $optlist { - set k2 [tcl::prefix::match -error "" $optnames $k] - switch -- $k2 { - -etabs - -type - -boxlimits - -boxmap - -joins - - -title - -subtitle - -width - -height - - -ansiborder - -ansibase - - -blockalign - -textalign - -ellipsis - - -crm_mode - - -usecache - -buildcache - -pad - - -checkargs { - tcl::dict::set opts $k2 $v - } - default { - #error "frame option '$k' not understood. Valid options are $optnames" - set opts_ok 0 - break - } - } - } - set check_args [dict get $opts -checkargs] - - #only use punk::args if check_args is true or our basic checks failed - #never need to checkargs if only one argument supplied even if it looks like an option - as it will be treated as data to frame - if {[llength $args] != 1 && (!$opts_ok || $check_args)} { - set argd [punk::args::get_by_id ::textblock::frame $args] - set opts [dict get $argd opts] - set contents [dict get $argd values contents] - } - - # -- --- --- --- --- --- - # cache relevant - set opt_usecache [tcl::dict::get $opts -usecache] - set opt_buildcache [tcl::dict::get $opts -buildcache] - set usecache $opt_usecache ;#may need to override - set opt_etabs [tcl::dict::get $opts -etabs] ;#affects contentwidth - needed before cache determination - set opt_crm_mode [tcl::dict::get $opts -crm_mode] - # -- --- --- --- --- --- - set opt_type [tcl::dict::get $opts -type] - set opt_boxlimits [tcl::dict::get $opts -boxlimits] - set opt_joins [tcl::dict::get $opts -joins] - set opt_boxmap [tcl::dict::get $opts -boxmap] - set buildcache $opt_buildcache - set opt_pad [tcl::dict::get $opts -pad] - # -- --- --- --- --- --- - set opt_title [tcl::dict::get $opts -title] - set opt_subtitle [tcl::dict::get $opts -subtitle] - set opt_width [tcl::dict::get $opts -width] - set opt_height [tcl::dict::get $opts -height] - # -- --- --- --- --- --- - set opt_ansiborder [tcl::dict::get $opts -ansiborder] - set opt_ansibase [tcl::dict::get $opts -ansibase] ;#experimental - set opt_ellipsis [tcl::dict::get $opts -ellipsis] - - set opt_blockalign [tcl::dict::get $opts -blockalign] - set opt_textalign [tcl::dict::get $opts -textalign] - - set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] - - set known_frametypes $frametypes ;# light, heavey etc as defined in the ::textblock::frametypes variable - set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] - - lassign [textblock::frametype $opt_type] _cat category _type ftype - if {$category eq "custom"} { - set custom_frame $ftype - set frameset "custom" - set framedef $custom_frame - } else { - #category = predefined - set frameset $ftype ;# light,heavy etc - set framedef $ftype - } - - #if check_args? - - - #REVIEW - now done in framedef? - #set join_directions [list] - ##targets - light,heavy (double?) - seem to be some required glyphs missing from unicode - ##e.g down-light, up-heavy - #set join_targets [tcl::dict::create left "" down "" right "" up ""] - #foreach jt $opt_joins { - # lassign [split $jt -] direction target - # if {$target ne ""} { - # tcl::dict::set join_targets $direction $target - # } - # lappend join_directions $direction - #} - #set join_directions [lsort -unique $join_directions] - #set do_joins [::join $join_directions _] - - - - - # -- --- --- --- --- --- - - if {$has_contents} { - if {[tcl::string::last \t $contents] >= 0} { - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - if {$opt_etabs} { - #todo - set contents [textutil::tabify::untabify2 $contents $tw] - } - } - set contents [tcl::string::map {\r\n \n} $contents] - if {$opt_crm_mode} { - if {$opt_height eq ""} { - set h [textblock::height $contents] - } else { - set h [expr {$opt_height -2}] - } - if {$opt_width eq ""} { - set w [textblock::width $contents] - } else { - set w [expr {$opt_width -2}] - } - set contents [overtype::renderspace -crm_mode 1 -wrap 1 -width $w -height $h "" $contents] - set actual_contentwidth $w - set actual_contentheight $h - } else { - #set actual_contentwidth [textblock::width $contents] ;#length of longest line in contents (contents can be ragged) - #set actual_contentheight [textblock::height $contents] - lassign [textblock::size_as_list $contents] actual_contentwidth actual_contentheight - } - } else { - set actual_contentwidth 0 - set actual_contentheight 0 - } - - if {$opt_title ne ""} { - set titlewidth [punk::ansi::printing_length $opt_title] - set content_or_title_width [expr {max($actual_contentwidth,$titlewidth)}] - } else { - set titlewith 0 - set content_or_title_width $actual_contentwidth - } - #opt_subtitle ?? - - if {$opt_width eq ""} { - set frame_inner_width $content_or_title_width - } else { - set frame_inner_width [expr {max(0,$opt_width - 2)}] ;#default - } - - if {$opt_height eq ""} { - set frame_inner_height $actual_contentheight - } else { - set frame_inner_height [expr {max(0,$opt_height -2)}] ;#default - } - if {$frame_inner_height == 0 && $frame_inner_width == 0} { - set has_contents 0 - } - #todo - render it with vertical overflow so we can process ansi moves? - #set linecount [textblock::height $contents] - set linecount $frame_inner_height - - # -- --- --- --- --- --- --- --- --- - variable frame_cache - #review - custom frame affects frame_inner_width - exclude from caching? - #set cache_key [concat $optlist $frame_inner_width $frame_inner_height] - #jmn - #set hashables [concat $optlist $frame_inner_width $frame_inner_height] - set hashables [list {*}$optlist $frame_inner_width $frame_inner_height] - - - switch -- $use_hash { - sha1 { - package require sha1 - set hash [sha1::sha1 [encoding convertto utf-8 $hashables]] - } - md5 { - package require md5 - if {[package vsatisfies [package present md5] 2- ] } { - set hash [md5::md5 -hex [encoding convertto utf-8 $hashables]] ;#need fast and unique to content - not cryptographic - review - } else { - set hash [md5::md5 [encoding convertto utf-8 $hashables]] - } - } - none { - set hash $hashables - } - } - - set cache_key "$hash-$frame_inner_width-$frame_inner_height-actualcontentwidth:$actual_contentwidth" - #should be in a unicode private range different to that used in table construction - #e.g BMP PUA U+E000 -> U+F8FF - although this is commonly used for example by nerdfonts - #also supplementary private use blocks - #however these display double wide on for example cmd terminal despite having wcswidth 1 (makes layout debugging difficult) - #U+F0000 -> U+FFFD - #U+100000 -> U+10FFFD - #FSUB options: \uf0ff \uF1FF \uf2ff (no nerdfont glyphs - should look like standard replacement char) \uF2DD (circular thingy) - #should be something someone is unlikely to use as part of a custom frame character. - #ideally a glyph that doesn't auto-expand into whitespace and is countable when in a string (narrower is better) - #As nerdfont glyphs tend to be mostly equal height & width - circular glyphs tend to be more distinguishable in a string - #terminal settings may need to be adjusted to stop auto glyph resizing - a rather annoying misfeature that some people seem to think they like. - #e.g in wezterm config: allow_square_glyphs_to_overflow_width = "Never" - #review - we could consider wasting a few cycles to check for a conflict and use a different FSUB - set FSUB \uF2DD - - - #this occurs commonly in table building with colspans - review - if {($actual_contentwidth > $frame_inner_width) || ($actual_contentheight != $frame_inner_height)} { - set usecache 0 - #set buildcache 0 ;#comment out for debug/analysis so we can see - #puts "--->> frame_inner_width:$frame_inner_width actual_contentwidth:$actual_contentwidth contents: '$contents'" - set cache_key [a+ Web-red web-white]$cache_key[a] - } - if {$buildcache && ($actual_contentwidth < $frame_inner_width)} { - #colourise cache_key to warn - if {$actual_contentwidth == 0} { - #we can still substitute with right length - set cache_key [a+ Web-steelblue web-black]$cache_key[a] - } else { - #actual_contentwidth is narrower than frame - check template's patternwidth - if {[tcl::dict::exists $frame_cache $cache_key]} { - set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] - } else { - set cache_patternwidth $actual_contentwidth - } - if {$actual_contentwidth < $cache_patternwidth} { - set usecache 0 - set cache_key [a+ Web-orange web-black]$cache_key[a] - } elseif {$actual_contentwidth == $cache_patternwidth} { - #set usecache 1 - } else { - #actual_contentwidth > pattern - set usecache 0 - set cache_key [a+ Web-red web-black]$cache_key[a] - } - } - } - - #JMN debug - #set usecache 0 - - set is_cached 0 - if {$usecache && [tcl::dict::exists $frame_cache $cache_key]} { - set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] - set template [tcl::dict::get $frame_cache $cache_key frame] - set used [tcl::dict::get $frame_cache $cache_key used] - tcl::dict::set frame_cache $cache_key used [expr {$used+1}] ;#update existing record - set is_cached 1 - } - - - # -- --- --- --- --- --- --- --- --- - if {!$is_cached} { - # -- --- --- --- --- - # -- --- --- --- --- - set is_joins_ok 1 - foreach v $opt_joins { - lassign [split $v -] direction target - switch -- $direction { - left - right - up - down {} - default { - set is_joins_ok 0 - break - } - } - switch -- $target { - "" - light - light_b - light_c - heavy - heavy_b - heavy_c - ascii - altg - arc - arc_b - arc_c - double - custom - block - block1 - block2 {} - default { - set is_joins_ok 0 - break - } - } - } - if {!$is_joins_ok} { - error "frame option -joins '$opt_joins' must contain only values from the set: left,right,up,down with targets heavy,light,ascii,altg,arc,double,block,block1,custom e.g down-light" - } - # -- --- --- --- --- --- - set is_boxmap_ok 1 - tcl::dict::for {boxelement subst} $opt_boxmap { - switch -- $boxelement { - hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} - hltj - hlbj - vllj - vlrj {} - default { - set is_boxmap_ok 0 - break - } - } - } - if {!$is_boxmap_ok} { - error "frame option -boxmap '$opt_boxmap' must contain only keys from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc,hltj,hlbj,vllj,vlrj" - } - # -- --- --- --- --- --- - #these are all valid commands for overtype:: - switch -- $opt_textalign { - left - right - centre - center {} - default { - error "frame option -textalign must be left|right|centre|center - received: $opt_textalign" - } - } - # -- --- --- --- --- --- - switch -- $opt_blockalign { - left - right - centre - center {} - default { - error "frame option -blockalign must be left|right|centre|center - received: $opt_blockalign" - } - } - # -- --- --- --- --- - # -- --- --- --- --- - set is_boxlimits_ok 1 - set exact_boxlimits [list] - foreach v $opt_boxlimits { - switch -- $v { - hl { - lappend exact_boxlimits hlt hlb - } - vl { - lappend exact_boxlimits vll vlr - } - hlt - hlb - vll - vlr - tlc - trc - blc - brc { - lappend exact_boxlimits $v - } - default { - #k not in custom_keys - set is_boxlimits_ok 0 - break - } - } - } - #review vllj etc? - if {!$is_boxlimits_ok} { - error "frame option -boxlimits '$opt_boxlimits' must contain only values from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" - } - set exact_boxlimits [lsort -unique $exact_boxlimits] - # -- --- --- --- --- --- - - - set rst [a] - #set column [tcl::string::repeat " " $frame_inner_width] ;#default - may need to override for custom frame - set underlayline [tcl::string::repeat " " $frame_inner_width] - set underlay [::join [lrepeat $linecount $underlayline] \n] - - - set vll_width 1 ;#default for all except custom (printing width) - set vlr_width 1 - - set framedef [textblock::framedef -joins $opt_joins $framedef] - tcl::dict::with framedef {} ;#extract vll,hlt,tlc etc vars - - #puts "---> $opt_boxmap" - #review - we handle double-wide in custom frames - what about for boxmaps? - tcl::dict::for {boxelement sub} $opt_boxmap { - if {$boxelement eq "vl"} { - set vll $sub - set vlr $sub - set hl $sub - } elseif {$boxelement eq "hl"} { - set hlt $sub - set hlb $sub - set hl $sub - } else { - set $boxelement $sub - } - } - - switch -- $frameset { - custom { - #REVIEW - textblock::table assumes that at least the vl elements are 1-wide - #generally supporting wider or taller custom frame elements would make for some interesting graphical possibilities though - #if no ansi, these widths are reasonable to maintain in grapheme_width_cached indefinitely - set vll_width [punk::ansi::printing_length $vll] - set hlb_width [punk::ansi::printing_length $hlb] - set hlt_width [punk::ansi::printing_length $hlt] - - set vlr_width [punk::ansi::printing_length $vlr] - - set tlc_width [punk::ansi::printing_length $tlc] - set trc_width [punk::ansi::printing_length $trc] - set blc_width [punk::ansi::printing_length $blc] - set brc_width [punk::ansi::printing_length $brc] - - - set framewidth [expr {$frame_inner_width + 2}] ;#reverse default assumption - if {$opt_width eq ""} { - #width wasn't specified - so user is expecting frame to adapt to title/contents - #content shouldn't truncate because of extra wide frame - #review - punk::console::get_size ? wrapping? quite hard to support with colspans - set frame_inner_width $content_or_title_width - set tbarwidth [expr {$content_or_title_width + 2 - $tlc_width - $trc_width - 2 + $vll_width + $vlr_width}] ;#+/2's for difference between border element widths and standard element single-width - set bbarwidth [expr {$content_or_title_width + 2 - $blc_width - $brc_width - 2 + $vll_width + $vlr_width}] - } else { - set frame_inner_width [expr $opt_width - $vll_width - $vlr_width] ;#content may be truncated - set tbarwidth [expr {$opt_width - $tlc_width - $trc_width}] - set bbarwidth [expr {$opt_width - $blc_width - $brc_width}] - } - #set column [tcl::string::repeat " " $frame_inner_width] - set underlayline [tcl::string::repeat " " $frame_inner_width] - set underlay [::join [lrepeat $linecount $underlayline] \n] - #cache? - - if {$hlt_width == 1} { - set tbar [tcl::string::repeat $hlt $tbarwidth] - } else { - #possibly mixed width chars that make up hlt - tcl::string::range won't get width right - set blank [tcl::string::repeat " " $tbarwidth] - if {$hlt_width > 0} { - set count [expr {($tbarwidth / $hlt_width) + 1}] - } else { - set count 0 - } - set tbar [tcl::string::repeat $hlt $count] - #set tbar [tcl::string::range $tbar 0 $tbarwidth-1] - set tbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $tbar];#spaces for exposed halves of 2w chars instead of default replacement character - } - if {$hlb_width == 1} { - set bbar [tcl::string::repeat $hlb $bbarwidth] - } else { - set blank [tcl::string::repeat " " $bbarwidth] - if {$hlb_width > 0} { - set count [expr {($bbarwidth / $hlb_width) + 1}] - } else { - set count 0 - } - set bbar [tcl::string::repeat $hlb $count] - #set bbar [tcl::string::range $bbar 0 $bbarwidth-1] - set bbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $bbar] - } - } - altg { - set tbar [tcl::string::repeat $hlt $frame_inner_width] - set tbar [cd::groptim $tbar] - set bbar [tcl::string::repeat $hlb $frame_inner_width] - set bbar [cd::groptim $bbar] - } - default { - set tbar [tcl::string::repeat $hlt $frame_inner_width] - set bbar [tcl::string::repeat $hlb $frame_inner_width] - - } - } - - set leftborder 0 - set rightborder 0 - set topborder 0 - set bottomborder 0 - # hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} - #puts "----->$exact_boxlimits" - foreach lim $exact_boxlimits { - switch -- $lim { - hlt { - set topborder 1 - } - hlb { - set bottomborder 1 - } - vll { - set leftborder 1 - } - vlr { - set rightborder 1 - } - tlc { - set topborder 1 - set leftborder 1 - } - trc { - set topborder 1 - set rightborder 1 - } - blc { - set bottomborder 1 - set leftborder 1 - } - brc { - set bottomborder 1 - set rightborder 1 - } - } - } - if {$opt_width ne "" && $opt_width < 2} { - set rightborder 0 - } - #keep lhs/rhs separate? can we do vertical text on sidebars? - set lhs [tcl::string::repeat $vll\n $linecount] - set lhs [tcl::string::range $lhs 0 end-1] - set rhs [tcl::string::repeat $vlr\n $linecount] - set rhs [tcl::string::range $rhs 0 end-1] - - - if {$opt_ansiborder ne ""} { - set tbar $opt_ansiborder$tbar$rst - set bbar $opt_ansiborder$bbar$rst - set tlc $opt_ansiborder$tlc$rst - set trc $opt_ansiborder$trc$rst - set blc $opt_ansiborder$blc$rst - set brc $opt_ansiborder$brc$rst - - set lhs $opt_ansiborder$lhs$rst ;#wrap the whole block and let textblock::join figure it out - set rhs $opt_ansiborder$rhs$rst - } - - #boxlimits used for partial borders in table generation - set all_exact_boxlimits [list vll vlr hlt hlb tlc blc trc brc] - set unspecified_limits [struct::set difference $all_exact_boxlimits $exact_boxlimits] - foreach lim $unspecified_limits { - switch -- $lim { - vll { - set blank_vll [tcl::string::repeat " " $vll_width] - set lhs [tcl::string::repeat $blank_vll\n $linecount] - set lhs [tcl::string::range $lhs 0 end-1] - } - vlr { - set blank_vlr [tcl::string::repeat " " $vlr_width] - set rhs [tcl::string::repeat $blank_vlr\n $linecount] - set rhs [tcl::string::range $rhs 0 end-1] - } - hlt { - set bar_width [punk::ansi::printing_length $tbar] - set tbar [tcl::string::repeat " " $bar_width] - } - tlc { - set tlc_width [punk::ansi::printing_length $tlc] - set tlc [tcl::string::repeat " " $tlc_width] - } - trc { - set trc_width [punk::ansi::printing_length $trc] - set trc [tcl::string::repeat " " $trc_width] - } - hlb { - set bar_width [punk::ansi::printing_length $bbar] - set bbar [tcl::string::repeat " " $bar_width] - } - blc { - set blc_width [punk::ansi::printing_length $blc] - set blc [tcl::string::repeat " " $blc_width] - } - brc { - set brc_width [punk::ansi::printing_length $brc] - set brc [tcl::string::repeat " " $brc_width] - } - } - } - - if {$opt_title ne ""} { - set topbar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $tbar $opt_title] ;#overtype supports gx0 on/off - } else { - set topbar $tbar - } - if {$opt_subtitle ne ""} { - set bottombar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $bbar $opt_subtitle] ;#overtype supports gx0 on/off - } else { - set bottombar $bbar - } - if {$opt_ansibase eq ""} { - set rstbase [a] - } else { - set rstbase [a]$opt_ansibase - } - - if {$opt_title ne ""} { - #title overrides -boxlimits for topborder - set topborder 1 - } - set fs "" - set fscached "" - set cache_patternwidth 0 - #todo - output nothing except maybe newlines depending on if opt_height 0 and/or opt_width 0? - if {$topborder} { - if {$leftborder && $rightborder} { - append fs $tlc$topbar$trc - } else { - if {$leftborder} { - append fs $tlc$topbar - } elseif {$rightborder} { - append fs $topbar$trc - } else { - append fs $topbar - } - } - } - append fscached $fs - if {$has_contents || $opt_height > 2} { - #if {$topborder && $fs ne "xx"} { - # append fs \n - #} - if {$topborder} { - append fs \n - append fscached \n - } - switch -- $opt_textalign { - right {set pad "left"} - left {set pad "right"} - default {set pad $opt_textalign} - } - #set textaligned_contents [textblock::pad $contents -width $actual_contentwidth -which $pad -within_ansi 1] - #set inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$textaligned_contents] - - set cache_contentline [tcl::string::repeat $FSUB $actual_contentwidth] - set cache_patternwidth $actual_contentwidth - set cache_contentpattern [::join [lrepeat $linecount $cache_contentline] \n] - set cache_inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$cache_contentpattern] - #after overtype::block - our actual patternwidth may be less - set cache_patternwidth [tcl::string::length [lindex [regexp -inline "\[^$FSUB]*(\[$FSUB]*).*" $cache_inner] 1]] - - if {$leftborder && $rightborder} { - #set bodyparts [list $lhs $inner $rhs] - set cache_bodyparts [list $lhs $cache_inner $rhs] - } else { - if {$leftborder} { - #set bodyparts [list $lhs $inner] - set cache_bodyparts [list $lhs $cache_inner] - } elseif {$rightborder} { - #set bodyparts [list $inner $rhs] - set cache_bodyparts [list $cache_inner $rhs] - } else { - #set bodyparts [list $inner] - set cache_bodyparts [list $cache_inner] - } - } - #set body [textblock::join -- {*}$bodyparts] - - #JMN test - #assert - lhs, cache_inner, rhs non-ragged - so can use join_basic REVIEW - #set cache_body [textblock::join -- {*}$cache_bodyparts] - set cache_body [textblock::join_basic -- {*}$cache_bodyparts] - - append fscached $cache_body - #append fs $body - } - - if {$opt_height eq "" || $opt_height > 1} { - if {$opt_subtitle ne ""} { - #subtitle overrides boxlimits for bottomborder - set bottomborder 1 - } - if {$bottomborder} { - if {($topborder & $fs ne "xx" ) || ($has_contents || $opt_height > 2)} { - #append fs \n - append fscached \n - } - if {$leftborder && $rightborder} { - #append fs $blc$bottombar$brc - append fscached $blc$bottombar$brc - } else { - if {$leftborder} { - #append fs $blc$bottombar - append fscached $blc$bottombar - } elseif {$rightborder} { - #append fs $bottombar$brc - append fscached $bottombar$brc - } else { - #append fs $bottombar - append fscached $bottombar - } - } - } - } - set template $fscached - ;#end !$is_cached - } - - - - - #use the same mechanism to build the final frame - whether from cache or template - if {$actual_contentwidth == 0} { - set fs [tcl::string::map [list $FSUB " "] $template] - } else { - set resultlines [list] - set overwritable [tcl::string::repeat $FSUB $cache_patternwidth] - set contentindex 0 - switch -- $opt_textalign { - left {set pad right} - right {set pad left} - default {set pad $opt_textalign} - } - - #review - if {[tcl::string::is integer -strict $opt_height] && $actual_contentheight < ($opt_height -2)} { - set diff [expr {($opt_height -2) - $actual_contentheight}] - append contents [::join [lrepeat $diff \n] ""] ;# should not affect actual_contentwidth - } - - #set cwidth [textblock::width $contents] - set cwidth $actual_contentwidth - if {$opt_pad} { - set paddedcontents [textblock::pad $contents -known_blockwidth $cwidth -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth) - set paddedwidth [textblock::widthtopline $paddedcontents] - #review - horizontal truncation - if {$paddedwidth > $cache_patternwidth} { - set paddedcontents [overtype::renderspace -width $cache_patternwidth "" $paddedcontents] - } - #important to supply end of opts -- to textblock::join - particularly here with arbitrary data - set contentblock [textblock::join -- $paddedcontents] ;#make sure each line has ansi replays - } else { - if {$cwidth > $cache_patternwidth} { - set contents [overtype::renderspace -width $cache_patternwidth "" $contents] - } - set contentblock [textblock::join -- $contents] ;# adds ansiresets and any required replays on each line - } - - set tlines [split $template \n] - - #we will need to strip off the leading reset on each line when stitching together with template lines so that ansibase can come into play too. - #after textblock::join the reset will be a separate code ie should be exactly ESC[0m - set R [a] - set rlen [tcl::string::length $R] - set clines [split $contentblock \n] - - foreach tline $tlines { - if {[tcl::string::first $FSUB $tline] >= 0} { - set content_line [lindex $clines $contentindex] - if {[tcl::string::first $R [string range $content_line 0 10]] == 0} { - set content_line [tcl::string::range $content_line $rlen end] - } - #make sure to replay opt_ansibase to the right of the replacement - lappend resultlines [tcl::string::map [list $overwritable $content_line$opt_ansibase] $tline] - incr contentindex - } else { - lappend resultlines $tline - } - } - set fs [::join $resultlines \n] - } - - - if {$is_cached} { - return $fs - } else { - if {$buildcache} { - tcl::dict::set frame_cache $cache_key [list frame $template used 0 patternwidth $cache_patternwidth] - } - return $fs - } - } - punk::args::definition { - @id -id ::textblock::gcross - -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 0 -max 1 - size -default 1 -type integer - } - proc gcross {args} { - set argd [punk::args::get_by_id ::textblock::gcross $args] - set size [dict get $argd values size] - set opts [dict get $argd opts] - - if {$size == 0} { - return "" - } - - set opt_max_cross_size [tcl::dict::get $opts -max_cross_size] - - #set fit_size [punk::lib::greatestOddFactor $size] - set fit_size $size - if {$opt_max_cross_size == 0} { - set max_cross_size $fit_size - } else { - #todo - only allow divisors - #set testsize [expr {min($fit_size,$opt_max_cross_size)}] - - set factors [punk::lib::factors $size] - #pick odd size in list that is smaller or equal to test_size - set max_cross_size [lindex $factors end] - set last_ok [lindex $factors 0] - for {set i 0} {$i < [llength $factors]} {incr i} { - set s [lindex $factors $i] - if {$s > $opt_max_cross_size} { - break - } - set last_ok $s - } - set max_cross_size $last_ok - } - set crosscount [expr {$size / $max_cross_size}] - - package require punk::char - set x [punk::char::charshort boxd_ldc] - set bs [punk::char::charshort boxd_ldgullr] - set fs [punk::char::charshort boxd_ldgurll] - - set onecross "" - set crossrows [list] - set armsize [expr {int(floor($max_cross_size /2))}] - set row [lrepeat $max_cross_size " "] - #toparm - for {set i 0} {$i < $armsize} {incr i} { - set r $row - lset r $i $bs - lset r end-$i $fs - #append onecross [::join $r ""] \n - lappend crossrows [::join $r ""] - } - - if {$max_cross_size % 2} { - #only put centre cross in for odd sized crosses - set r $row - lset r $armsize $x - #append onecross [::join $r ""] \n - lappend crossrows [::join $r ""] - } - - for {set i [expr {$armsize -1}]} {$i >= 0} {incr i -1} { - set r $row - lset r $i $fs - lset r end-$i $bs - #append onecross [::join $r ""] \n - lappend crossrows [::join $r ""] - } - #set onecross [tcl::string::trimright $onecross \n] - set onecross [::join $crossrows \n] - - #fastest to do row first then columns - because textblock::join must do line by line - - if {$crosscount > 1} { - set row [textblock::join -- {*}[lrepeat $crosscount $onecross]] - set rows [lrepeat $crosscount $row] - set out [::join $rows \n] - } else { - set out $onecross - } - - return $out - } - - #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] - puts $result - #return [list $b1 $b2 $result] - return [ansistring VIEW $result] - } - tcl::namespace::import ::punk::ansi::ansistrip -} - - -tcl::namespace::eval ::textblock::piper { - tcl::namespace::export * - proc join {rhs pipelinedata} { - tailcall ::textblock::join -- $pipelinedata $rhs - } -} -interp alias {} piper_blockjoin {} ::textblock::piper::join - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide textblock [tcl::namespace::eval textblock { - variable version - set version 0.1.2 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/uuid-1.0.7.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/uuid-1.0.7.tm deleted file mode 100644 index fbd43f3d..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/uuid-1.0.7.tm +++ /dev/null @@ -1,245 +0,0 @@ -# uuid.tcl - Copyright (C) 2004 Pat Thoyts -# -# UUIDs are 128 bit values that attempt to be unique in time and space. -# -# Reference: -# http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt -# -# uuid: scheme: -# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html -# -# Usage: uuid::uuid generate -# uuid::uuid equal $idA $idB - -package require Tcl 8.5 - -namespace eval uuid { - variable accel - array set accel {critcl 0} - - namespace export uuid - - variable uid - if {![info exists uid]} { - set uid 1 - } - - proc K {a b} {set a} -} - -### -# Optimization -# Caches machine info after the first pass -### - -proc ::uuid::generate_tcl_machinfo {} { - variable machinfo - if {[info exists machinfo]} { - return $machinfo - } - lappend machinfo [clock seconds]; # timestamp - lappend machinfo [clock clicks]; # system incrementing counter - lappend machinfo [info hostname]; # spatial unique id (poor) - lappend machinfo [pid]; # additional entropy - lappend machinfo [array get ::tcl_platform] - - ### - # If we have /dev/urandom just stream 128 bits from that - ### - if {[file exists /dev/urandom]} { - set fin [open /dev/urandom r] - binary scan [read $fin 128] H* machinfo - close $fin - } elseif {[catch {package require nettool}]} { - # More spatial information -- better than hostname. - # bug 1150714: opening a server socket may raise a warning messagebox - # with WinXP firewall, using ipconfig will return all IP addresses - # including ipv6 ones if available. ipconfig is OK on win98+ - if {[string equal $::tcl_platform(platform) "windows"]} { - catch {exec ipconfig} config - lappend machinfo $config - } else { - catch { - set s [socket -server void -myaddr [info hostname] 0] - K [fconfigure $s -sockname] [close $s] - } r - lappend machinfo $r - } - - if {[package provide Tk] != {}} { - lappend machinfo [winfo pointerxy .] - lappend machinfo [winfo id .] - } - } else { - ### - # If the nettool package works on this platform - # use the stream of hardware ids from it - ### - lappend machinfo {*}[::nettool::hwid_list] - } - return $machinfo -} - -# Generates a binary UUID as per the draft spec. We generate a pseudo-random -# type uuid (type 4). See section 3.4 -# -proc ::uuid::generate_tcl {} { - package require md5 2 - variable uid - - set tok [md5::MD5Init] - md5::MD5Update $tok [incr uid]; # package incrementing counter - foreach string [generate_tcl_machinfo] { - md5::MD5Update $tok $string - } - set r [md5::MD5Final $tok] - binary scan $r c* r - - # 3.4: set uuid versioning fields - lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}] - lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}] - - return [binary format c* $r] -} - -if {[string equal $tcl_platform(platform) "windows"] - && [package provide critcl] != {}} { - namespace eval uuid { - critcl::ccode { - #define WIN32_LEAN_AND_MEAN - #define STRICT - #include - #include - typedef long (__stdcall *LPFNUUIDCREATE)(UUID *); - typedef const unsigned char cu_char; - } - critcl::cproc generate_c {Tcl_Interp* interp} ok { - HRESULT hr = S_OK; - int r = TCL_OK; - UUID uuid = {0}; - HMODULE hLib; - LPFNUUIDCREATE lpfnUuidCreate = NULL; - hLib = LoadLibraryA(("rpcrt4.dll")); - if (hLib) - lpfnUuidCreate = (LPFNUUIDCREATE) - GetProcAddress(hLib, "UuidCreate"); - if (lpfnUuidCreate) { - Tcl_Obj *obj; - lpfnUuidCreate(&uuid); - obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid)); - Tcl_SetObjResult(interp, obj); - } else { - Tcl_SetResult(interp, "error: failed to create a guid", - TCL_STATIC); - r = TCL_ERROR; - } - return r; - } - } -} - -# Convert a binary uuid into its string representation. -# -proc ::uuid::tostring {uuid} { - binary scan $uuid H* s - foreach {a b} {0 7 8 11 12 15 16 19 20 end} { - append r [string range $s $a $b] - - } - return [string tolower [string trimright $r -]] -} - -# Convert a string representation of a uuid into its binary format. -# -proc ::uuid::fromstring {uuid} { - return [binary format H* [string map {- {}} $uuid]] -} - -# Compare two uuids for equality. -# -proc ::uuid::equal {left right} { - set l [fromstring $left] - set r [fromstring $right] - return [string equal $l $r] -} - -# Call our generate uuid implementation -proc ::uuid::generate {} { - variable accel - if {$accel(critcl)} { - return [generate_c] - } else { - return [generate_tcl] - } -} - -# uuid generate -> string rep of a new uuid -# uuid equal uuid1 uuid2 -# -proc uuid::uuid {cmd args} { - switch -exact -- $cmd { - generate { - if {[llength $args] != 0} { - return -code error "wrong # args:\ - should be \"uuid generate\"" - } - return [tostring [generate]] - } - equal { - if {[llength $args] != 2} { - return -code error "wrong \# args:\ - should be \"uuid equal uuid1 uuid2\"" - } - return [eval [linsert $args 0 equal]] - } - default { - return -code error "bad option \"$cmd\":\ - must be generate or equal" - } - } -} - -# ------------------------------------------------------------------------- - -# LoadAccelerator -- -# -# This package can make use of a number of compiled extensions to -# accelerate the digest computation. This procedure manages the -# use of these extensions within the package. During normal usage -# this should not be called, but the test package manipulates the -# list of enabled accelerators. -# -proc ::uuid::LoadAccelerator {name} { - variable accel - set r 0 - switch -exact -- $name { - critcl { - if {![catch {package require tcllibc}]} { - set r [expr {[info commands ::uuid::generate_c] != {}}] - } - } - default { - return -code error "invalid accelerator package:\ - must be one of [join [array names accel] {, }]" - } - } - set accel($name) $r -} - -# ------------------------------------------------------------------------- - -# Try and load a compiled extension to help. -namespace eval ::uuid { - variable e {} - foreach e {critcl} { - if {[LoadAccelerator $e]} break - } - unset e -} - -package provide uuid 1.0.7 - -# ------------------------------------------------------------------------- -# Local variables: -# mode: tcl -# indent-tabs-mode: nil -# End: diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/uuid-1.0.8.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/uuid-1.0.8.tm deleted file mode 100644 index c5cffa67..00000000 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/uuid-1.0.8.tm +++ /dev/null @@ -1,246 +0,0 @@ -# uuid.tcl - Copyright (C) 2004 Pat Thoyts -# -# UUIDs are 128 bit values that attempt to be unique in time and space. -# -# Reference: -# http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt -# -# uuid: scheme: -# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html -# -# Usage: uuid::uuid generate -# uuid::uuid equal $idA $idB - -package require Tcl 8.5 9 - -namespace eval uuid { - variable accel - array set accel {critcl 0} - - namespace export uuid - - variable uid - if {![info exists uid]} { - set uid 1 - } - - proc K {a b} {set a} -} - -### -# Optimization -# Caches machine info after the first pass -### - -proc ::uuid::generate_tcl_machinfo {} { - variable machinfo - if {[info exists machinfo]} { - return $machinfo - } - lappend machinfo [clock seconds]; # timestamp - lappend machinfo [clock clicks]; # system incrementing counter - lappend machinfo [info hostname]; # spatial unique id (poor) - lappend machinfo [pid]; # additional entropy - lappend machinfo [array get ::tcl_platform] - - ### - # If we have /dev/urandom just stream 128 bits from that - ### - if {[file exists /dev/urandom]} { - set fin [open /dev/urandom r] - fconfigure $fin -encoding binary - binary scan [read $fin 128] H* machinfo - close $fin - } elseif {[catch {package require nettool}]} { - # More spatial information -- better than hostname. - # bug 1150714: opening a server socket may raise a warning messagebox - # with WinXP firewall, using ipconfig will return all IP addresses - # including ipv6 ones if available. ipconfig is OK on win98+ - if {[string equal $::tcl_platform(platform) "windows"]} { - catch {exec ipconfig} config - lappend machinfo $config - } else { - catch { - set s [socket -server void -myaddr [info hostname] 0] - K [fconfigure $s -sockname] [close $s] - } r - lappend machinfo $r - } - - if {[package provide Tk] != {}} { - lappend machinfo [winfo pointerxy .] - lappend machinfo [winfo id .] - } - } else { - ### - # If the nettool package works on this platform - # use the stream of hardware ids from it - ### - lappend machinfo {*}[::nettool::hwid_list] - } - return $machinfo -} - -# Generates a binary UUID as per the draft spec. We generate a pseudo-random -# type uuid (type 4). See section 3.4 -# -proc ::uuid::generate_tcl {} { - package require md5 2 - variable uid - - set tok [md5::MD5Init] - md5::MD5Update $tok [incr uid]; # package incrementing counter - foreach string [generate_tcl_machinfo] { - md5::MD5Update $tok $string - } - set r [md5::MD5Final $tok] - binary scan $r c* r - - # 3.4: set uuid versioning fields - lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}] - lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}] - - return [binary format c* $r] -} - -if {[string equal $tcl_platform(platform) "windows"] - && [package provide critcl] != {}} { - namespace eval uuid { - critcl::ccode { - #define WIN32_LEAN_AND_MEAN - #define STRICT - #include - #include - typedef long (__stdcall *LPFNUUIDCREATE)(UUID *); - typedef const unsigned char cu_char; - } - critcl::cproc generate_c {Tcl_Interp* interp} ok { - HRESULT hr = S_OK; - int r = TCL_OK; - UUID uuid = {0}; - HMODULE hLib; - LPFNUUIDCREATE lpfnUuidCreate = NULL; - hLib = LoadLibraryA(("rpcrt4.dll")); - if (hLib) - lpfnUuidCreate = (LPFNUUIDCREATE) - GetProcAddress(hLib, "UuidCreate"); - if (lpfnUuidCreate) { - Tcl_Obj *obj; - lpfnUuidCreate(&uuid); - obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid)); - Tcl_SetObjResult(interp, obj); - } else { - Tcl_SetResult(interp, "error: failed to create a guid", - TCL_STATIC); - r = TCL_ERROR; - } - return r; - } - } -} - -# Convert a binary uuid into its string representation. -# -proc ::uuid::tostring {uuid} { - binary scan $uuid H* s - foreach {a b} {0 7 8 11 12 15 16 19 20 end} { - append r [string range $s $a $b] - - } - return [string tolower [string trimright $r -]] -} - -# Convert a string representation of a uuid into its binary format. -# -proc ::uuid::fromstring {uuid} { - return [binary format H* [string map {- {}} $uuid]] -} - -# Compare two uuids for equality. -# -proc ::uuid::equal {left right} { - set l [fromstring $left] - set r [fromstring $right] - return [string equal $l $r] -} - -# Call our generate uuid implementation -proc ::uuid::generate {} { - variable accel - if {$accel(critcl)} { - return [generate_c] - } else { - return [generate_tcl] - } -} - -# uuid generate -> string rep of a new uuid -# uuid equal uuid1 uuid2 -# -proc uuid::uuid {cmd args} { - switch -exact -- $cmd { - generate { - if {[llength $args] != 0} { - return -code error "wrong # args:\ - should be \"uuid generate\"" - } - return [tostring [generate]] - } - equal { - if {[llength $args] != 2} { - return -code error "wrong \# args:\ - should be \"uuid equal uuid1 uuid2\"" - } - return [eval [linsert $args 0 equal]] - } - default { - return -code error "bad option \"$cmd\":\ - must be generate or equal" - } - } -} - -# ------------------------------------------------------------------------- - -# LoadAccelerator -- -# -# This package can make use of a number of compiled extensions to -# accelerate the digest computation. This procedure manages the -# use of these extensions within the package. During normal usage -# this should not be called, but the test package manipulates the -# list of enabled accelerators. -# -proc ::uuid::LoadAccelerator {name} { - variable accel - set r 0 - switch -exact -- $name { - critcl { - if {![catch {package require tcllibc}]} { - set r [expr {[info commands ::uuid::generate_c] != {}}] - } - } - default { - return -code error "invalid accelerator package:\ - must be one of [join [array names accel] {, }]" - } - } - set accel($name) $r -} - -# ------------------------------------------------------------------------- - -# Try and load a compiled extension to help. -namespace eval ::uuid { - variable e {} - foreach e {critcl} { - if {[LoadAccelerator $e]} break - } - unset e -} - -package provide uuid 1.0.8 - -# ------------------------------------------------------------------------- -# Local variables: -# mode: tcl -# indent-tabs-mode: nil -# End: diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/zipper-0.11.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/zipper-0.11.tm deleted file mode 100644 index 2f72c19e..00000000 Binary files a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/zipper-0.11.tm and /dev/null differ diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl b/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl index c1d3f906..858c0d2d 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl @@ -1263,6 +1263,8 @@ proc ::punkboot::punkboot_gethelp {args} { append h " - show the name and base folder of the project to be built" \n \n append h " $scriptname check" \n append h " - show module/library paths and any potentially problematic packages for running this script" \n + append h " $scriptname shell" \n + append h " - run the punk shell using bootsupport libraries." \n append h "" \n if {[llength [dict get $pkg_availability missing]] || [llength [dict get $pkg_availability broken]]} { set has_recommended 0 @@ -1331,8 +1333,9 @@ punk::args::define { subcommand -type "literal(shell)" arg -type any -optional 1 -multiple 1 } + #set argd [punk::args::parse $scriptargs -form 0 withid punkmake] -##lassign [dict values $argd] leaders opts values received +###lassign [dict values $argd] leaders opts values received # #puts stdout [punk::args::usage -scheme nocolour punkmake] #exit 1 diff --git a/src/project_layouts/vendor/punk/project-0.1/src/lib/app_project/app_project.tcl b/src/project_layouts/vendor/punk/project-0.1/src/lib/app_project/app_project.tcl new file mode 100644 index 00000000..6e716af6 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/lib/app_project/app_project.tcl @@ -0,0 +1,6 @@ +package provide app_project 0.1 + +puts stderr "app_project package loaded. Todo: customize" +# add behaviour based on $::argc $::argv here +# or alternatively - just package require a lib/module which examines the arguments +# package require projectcore 1.0 diff --git a/src/project_layouts/vendor/punk/project-0.1/src/lib/app_project/pkgIndex.tcl b/src/project_layouts/vendor/punk/project-0.1/src/lib/app_project/pkgIndex.tcl new file mode 100644 index 00000000..34226e5a --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/lib/app_project/pkgIndex.tcl @@ -0,0 +1 @@ +package ifneeded app-project 0.1 [list source [file join $dir app_project.tcl]] diff --git a/src/project_layouts/vendor/punk/project-0.1/src/vfs/_config/project_main.tcl b/src/project_layouts/vendor/punk/project-0.1/src/vfs/_config/project_main.tcl new file mode 100644 index 00000000..db9d3190 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/vfs/_config/project_main.tcl @@ -0,0 +1,881 @@ + + +#main.tcl - we expect to be in the context of a zipkit or tclkit vfs attached to a tcl executable. +# or cookfs ? +#review - what happens if multiple are somehow attached and for example both vfs and zipfs are available? +# - if that's even possible - we have no control here over which main.tcl was selected as we're already here +# a metakit data portion seems to need to be add the end of the file (from looking at sdx.kit code) +# - todo - investigate if zipfs can be inserted between starkit head executable and metakit tail data +#The logic below will add appropriate package paths from starkit and zipfs vfs paths +# - and restrict package paths to those coming from a vfs (if not launched with 'dev' or 'os' first arg which allows external paths to remain) + + + +apply { args { + set tclmajorv [lindex [split [info tclversion] .] 0] + namespace eval ::punkboot { + #This is somewhat ugly - but we don't want to do any 'package require' operations at this stage + # even for something that is available in tcl_library. + #review + proc platform_generic {} { + #platform::generic - snipped straight from platform package + global tcl_platform + + set plat [string tolower [lindex $tcl_platform(os) 0]] + set cpu $tcl_platform(machine) + + switch -glob -- $cpu { + sun4* { + set cpu sparc + } + intel - + ia32* - + i*86* { + set cpu ix86 + } + x86_64 { + if {$tcl_platform(wordSize) == 4} { + # See Example <1> at the top of this file. + set cpu ix86 + } + } + ppc - + "Power*" { + set cpu powerpc + } + "arm*" { + set cpu arm + } + ia64 { + if {$tcl_platform(wordSize) == 4} { + append cpu _32 + } + } + } + + switch -glob -- $plat { + windows { + if {$tcl_platform(platform) == "unix"} { + set plat cygwin + } else { + set plat win32 + } + if {$cpu eq "amd64"} { + # Do not check wordSize, win32-x64 is an IL32P64 platform. + set cpu x86_64 + } + } + sunos { + set plat solaris + if {[string match "ix86" $cpu]} { + if {$tcl_platform(wordSize) == 8} { + set cpu x86_64 + } + } elseif {![string match "ia64*" $cpu]} { + # sparc + if {$tcl_platform(wordSize) == 8} { + append cpu 64 + } + } + } + darwin { + set plat macosx + # Correctly identify the cpu when running as a 64bit + # process on a machine with a 32bit kernel + if {$cpu eq "ix86"} { + if {$tcl_platform(wordSize) == 8} { + set cpu x86_64 + } + } + } + aix { + set cpu powerpc + if {$tcl_platform(wordSize) == 8} { + append cpu 64 + } + } + hp-ux { + set plat hpux + if {![string match "ia64*" $cpu]} { + set cpu parisc + if {$tcl_platform(wordSize) == 8} { + append cpu 64 + } + } + } + osf1 { + set plat tru64 + } + default { + set plat [lindex [split $plat _-] 0] + } + } + + return "${plat}-${cpu}" + } + } + + set has_zipfs [expr {[info commands tcl::zipfs::root] ne ""}] + if {$has_zipfs} { + set has_zipfs_attached [expr {[llength [tcl::zipfs::mount]]}] + } else { + set has_zipfs_attached 0 + } + + #REVIEW - cookit/cookfs can be compiled with a different name for it's mount-point + # - we could examine the -handle from 'file attr' for each //something:/ volume (excluding //zipfs:/) + # - but there are situations where handle is empty (? punk repl issue?) + # - for now we only support the known name - REVIEW + set has_cookfs [expr {"//cookit:/" in [file volumes]}] + set cookbase //cookit:/ ;#always define it so we can test on it later.. + if {$has_cookfs} { + set has_cookfs_attached [file exists //cookit:/lib] ;# //cookit:/manifest.txt ? REVIEW + } else { + set has_cookfs_attached 0 + } + + + #here we make an attempt to avoid premature (costly) auto_path/tcl::tm::list scanning caused by our initial 'package require starkit'. + #we will first look for a starkit.tcl in an expected location and try to load that, then fallback to package require. + + #standard way to avoid symlinking issues - review! + set normscript [file dirname [file normalize [file join [info script] __dummy__]]] + + #The normalize is important as capitalisation must be retained (on all platforms) + set normexe [file dirname [file normalize [file join [info nameofexecutable] __dummy__]]] + + + #puts stderr "STARKIT: [package provide starkit]" + + set topdir [file dirname $normscript] + set found_starkit_tcl 0 + set possible_lib_vfs_folders [glob -nocomplain -dir [file join $topdir lib] -type d vfs*] + if {$has_zipfs_attached} { + if {[file exists [zipfs root]/app/tcl_library]} { + lappend possible_lib_vfs_folders {*}[glob -nocomplain -dir [zipfs root]/app/tcl_library -type d vfs*] + } + } + foreach test_folder $possible_lib_vfs_folders { + #e.g /lib/vfs1.4.1 + #we don't expect multiple vfs* folders - but we will process any found and load the pkgIndex.tcl from these folders. + #order of folder processing shouldn't matter (rely on order returned by 'package versions' - review) + if {[file exists $test_folder/starkit.tcl] && [file exists $test_folder/pkgIndex.tcl]} { + set dir $test_folder + source $test_folder/pkgIndex.tcl + } + } + #package versions does not always return versions in increasing order! + if {[set starkitv [lindex [lsort -command {package vcompare} [package versions starkit]] end]] ne ""} { + #run the ifneeded script for the latest found (assuming package versions ordering is correct) + #puts "111 autopath: $::auto_path" + eval [package ifneeded starkit $starkitv] + set found_starkit_tcl 1 + #puts "222 autopath: $::auto_path" + } + if {!$found_starkit_tcl} { + #our internal 'quick' search for starkit failed. + #either we are in a pure zipfs system, or cookfs - or the starkit package is somewhere more devious + #for pure zipfs or cookfs - it's a little wasteful to perform exhaustive search for starkit + #review - only keep searching if not 'dev' first arg? + + #Initially we've done no scans of auto_path/tcl::tm::list - but there will already be a core set of packages known by the kit + #retain it so we can 'forget' the difference after our first 'package require' forces a full scan which includes some paths we may not wish to include or at least include with different preferences + #puts "main.tcl 1)--> package name count: [llength [package names]]" + #puts stderr [join [package names] \n] + set original_packages [package names] + + #This is what we were trying to avoid - a package require causing a scan of ::auto_path and tcl::tm::list + if {![catch {package require starkit}]} { + #known side-effects of starkit::startup + #sets the ::starkit::mode variable to the way in which it was launched. One of: {starpack starkit unwrapped tclhttpd plugin service sourced} + #set the ::starkit::topdir variable + #if mode not starpack, then: + # - adds $::starkit::topdir/lib to the auto_path if not already present + # + #In the context of a metakit vfs attached to tcl kit executable - we expect the launch mode to be 'starkit' + set starkit_startmode [starkit::startup] + #However - we may also get here for a zipfs enabled tcl with a zifps vfs attached - but which has vlerq, starkit and vfs libraries available, + #in which case the mode seems to be reported as 'unwrapped' + #puts stderr "STARKIT MODE: $starkit_startmode" + } + #puts "main.tcl 2)--> package name count: [llength [package names]]" + foreach pkg [package names] { + if {$pkg ni $original_packages} { + package forget $pkg + } + } + #puts "main.tcl 3)--> package name count: [llength [package names]]" + } + + + + # -- --- --- + #when run as a tclkit - the exe is mounted as a dir and Tcl's auto_execok doesn't find it. review - for what versions of Tcl does this apply? + #known to occur in old 8.6.8 kits as well as 8.7 + #review - do we want $normexe or [info nameofexecutable] for $thisexe here? Presumably [info nameofexecutable] (possible symlink) ok + #we want to be able to launch a process from the interactive shell using the same name this one was launched with. + set thisexe [file tail [info nameofexecutable]] ;#e.g punk86.exe + set thisexeroot [file rootname $thisexe] ;#e.g punk86 + set ::auto_execs($thisexeroot) [info nameofexecutable] + if {$thisexe ne $thisexeroot} { + #on windows make the .exe point there too + set ::auto_execs($thisexe) [info nameofexecutable] + } + # -- --- --- + + set tm_additions_internal [list] + set tm_additions_dev [list] + set auto_path_additions_internal [list] + set auto_path_additions_dev [list] + + set lc_auto_path [string tolower $::auto_path] + + #inital auto_path setup by init.tcl + #firstly it includes env(TCLLIBPATH) + #then it adds the tcl_library folder and its parent + #e.g //zipfs:/app/tcl_library and //zipfs:/app + #when 'dev' or 'os' is not supplied - any non internal paths (usually those from env(TCLLIBPATH) will be stripped + #so that everything is self-contained in the kit/zipkit + + #puts "\x1b\[1\;33m main.tcl original auto_path: $::auto_path" + + if {[info exists ::tcl::kitpath] && $::tcl::kitpath ne ""} { + set kp $::tcl::kitpath + set kp [file normalize $kp] ;#tcl::kitpath needs to be capitalised as per the actual path + + #set existing_module_paths [string tolower [tcl::tm::list]] + foreach p [list modules modules_tcl$tclmajorv] { + #if {[string tolower [file join $kp $p]] ni $existing_module_paths} { + # tcl::tm::add [file join $kp $p] + #} + lappend tm_additions_internal [file join $kp $p] + } + foreach p [list lib lib_tcl$tclmajorv] { + lappend auto_path_additions_internal [file join $kp $p] + } + } + if {$has_zipfs_attached} { + #review build option may be different - tclZipFs.c ZIPFS_APP_MOUNT defaults to ZIPFS_VOLUME/app - but it could be something else. (why?) + #default 'zipfs root' has trailing slash (//zipfs:/) - but file join does the right thing + set zipbase [file join [tcl::zipfs::root] app] + if {"$zipbase" in [tcl::zipfs::mount]} { + #set existing_module_paths [string tolower [tcl::tm::list]] + foreach p [list modules modules_tcl$tclmajorv] { + #if {[string tolower [file join $zipbase $p]] ni $existing_module_paths} { + # tcl::tm::add [file join $zipbase $p] + #} + lappend tm_additions_internal [file join $zipbase $p] + } + foreach p [list lib lib_tcl$tclmajorv] { + lappend auto_path_additions_internal [file join $zipbase $p] + } + } + } + if {$has_cookfs_attached} { + #set existing_module_paths [string tolower [tcl::tm::list]] + foreach p [list modules modules_tcl$tclmajorv] { + #if {[string tolower [file join $cookbase $p]] ni $existing_module_paths} { + # tcl::tm::add [file join $cookbase $p] + #} + lappend tm_additions_internal [file join $cookbase $p] + } + foreach p [list lib lib_tcl$tclmajorv] { + lappend auto_path_additions_internal [file join $cookbase $p] + } + } + + + + set internal_paths [list] + if {$has_zipfs} { + set ziproot [tcl::zipfs::root] ;#root is enough to determine internal zipkit path + lappend internal_paths $ziproot + } + if {[info exists ::tcl::kitpath] && $::tcl::kitpath ne ""} { + lappend internal_paths $::tcl::kitpath + } + if {$has_cookfs} { + lappend internal_paths $cookbase + } + + #REVIEW + if {[info exists ::punkboot::internal_paths] && [llength $::punkboot::internal_paths]} { + #somewhat ugly cooperation with external sourcing scripts + lappend internal_paths {*}$::punkboot::internal_paths + } + + + # ----------------------------------------------------------------------------------------------------------- + # dev - refers to module and library paths relative to the project (executable path) + # os - refers to modules and library paths gleaned from ::env (TCLLIBPATH and TCL__TM_PATH) + # internal - refers to modules and libraries supplied from the mounted filesystem of a kit or zipfs based executable + # ----------------------------------------------------------------------------------------------------------- + # Note that unlike standard 'package unknown' punk::libunknown does not stop searching for packages when a .tm file is found that matches requirements, + # The auto_path is still examined. (avoids quirks where higher versioned pkgIndex based package not always found) + # ----------------------------------------------------------------------------------------------------------- + set all_package_modes [list dev os internal] + #package_mode is specified as a dash-delimited ordered value e.g dev-os + #"internal" is the default and if not present is always added to the list + #i.e "dev-os" is equivalent to "dev-os-internal" + #"os" is equivalent to "os-internal" + #"internal-os" and "internal" are left as is. + #The effective package_mode has 1 2 or 3 members. + # The only case where it has 1 member is if just "internal" is specified. + #This gives the number of permutations as how many ways to choose 3 items plus how many ways to choose 2 of the 3 items (one must be 'internal') plus the sole allowable way to choose 1 + #for a total of 11 possible final orderings. + #(16 possible values for package_mode argument when you include the short-forms "",os,dev,os-dev,dev-os which always have 'internal' appended) + set test_package_mode [lindex $args 0] + + switch -exact -- $test_package_mode { + internal - + os-internal - dev-internal - internal-os - internal-dev - + os-dev-internal - os-internal-dev - dev-os-internal - dev-internal-os - internal-os-dev - internal-dev-os { + #fully specified ('internal' is present) + set package_modes [split $test_package_mode -] + set arglist [lrange $args 1 end] + } + os - dev - os-dev - dev-os { + #partially specified - 'internal' ommitted but implied at tail + set package_modes [list {*}[split $test_package_mode -] internal] + set arglist [lrange $args 1 end] + } + default { + #empty first arg - or some unrelated arg + set package_modes internal + if {$test_package_mode eq ""} { + #consume the empty first arg as an equivalent of 'internal' + #don't consume any first arg that isn't recognised as a package_mode + set arglist [lrange $args 1 end] + } else { + set arglist $args + } + } + } + #assert: arglist has had any first arg that is a package_mode (including empty string) stripped. + set ::argv $arglist + set ::argc [llength $arglist] + #assert: package_modes is now a list of at least length 1 (in which case the only possible value is: internal) + #Note regarding the use of package forget and binary packages + #If the package has loaded a binary component - then a package forget and a subsequent package require can result in both binaries being present, as seen in 'info loaded' result - potentially resulting in anomalous behaviour + #In general package forget after a package has already been required may need special handling and should be avoided where possible. + #Only a limited set of packages support unloading a binary component anyway. + #We limit the use of 'package forget' here to packages that have not been loaded (whether pure-tcl or not) + #ie in this context it is used only for manipulating preferences of which packages are loaded in the first place + + #Unintuitive preferencing can occur if the same package version is for example present in a tclkit and in a module or lib folder external to the kit. + #It may be desired for performance or testing reasons to preference the library outside of the kit - and raising the version number may not always be possible/practical. + + #If the executable is a kit - we don't know what packages it contains or whether it allows loading from env based external paths. + #For app-punk projects - the lib/module paths based on the project being run should take preference if 'dev' is earlier in the list, even if the version number is the same. + #(these are the 'info nameofexecutable' or 'info script' or 'pwd' relative paths that are added here) + #Some kits will remove lib/module paths (from auto_path & tcl::tm::list) that have been added via TCLLIBPATH / TCLX_Y_TM_PATH environment variables + #Some kits will remove those env-provided lib paths but fail to remove the env-provided module paths + #(differences in boot.tcl in the kits) + + if {[llength $package_modes] > 1} { + #puts stderr "main.tcl PACKAGE MODE is preferencing libraries and modules in the order: $package_modes" + #puts stderr "main.tcl original auto_path: $::auto_path" + + + #------------------------------------------------------------------------------ + #Module loading + #------------------------------------------------------------------------------ + #If the current directory contains .tm files when the punk repl starts - then it will attempt to preference them + # - but first add our other known relative modules paths - as it won't make sense to use current directory as a modulepath if it's an ancestor of one of these.. + + #original tm list at this point consists of whatever the kit decided + some prepended internal kit paths that punk decided on. + #we want to bring the existing external paths to the position specified by package_mode (probably from the kit looking at various env TCL* values) + #we want to maintain the order of the internal paths. + #we want to add our external dev paths to the position specified by package_mode + + #assert [llength [package names]] should be small at this point ~ <10 ? + + set original_tm_list [tcl::tm::list] + tcl::tm::remove {*}$original_tm_list + + # -- --- --- --- --- --- --- --- + #split existing paths into internal & external + set internal_tm_dirs [list] ;# + set external_tm_dirs [list] + set lcase_internal_paths [string tolower $internal_paths] + foreach tm $original_tm_list { + #review - do we know original tm list was properly normalised? (need capitalisation consistent for path keys) + set tmlower [string tolower $tm] + set is_internal 0 + foreach okprefix $lcase_internal_paths { + if {[string match "$okprefix*" $tmlower]} { + lappend internal_tm_dirs $tm + set is_internal 1 + break + } + } + if {!$is_internal} { + lappend external_tm_dirs $tm + } + } + # -- --- --- --- --- --- --- --- + set original_external_tm_dirs $external_tm_dirs ;#we check some of our additions and bring to front - so we refer to external list as provided by kit + #assert internal_tm_dirs and external_tm_dirs have their case preserved.. + + set module_folders [list] + + #review - the below statement doesn't seem to be true. + #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 + + #2) + # .../bin/punkXX.exe look for ../modules (i.e modules folder at same level as bin folder) + #using normexe under assumption [info name] might be symlink - and more likely to be where the modules are located. + #we will try both relative to symlink and relative to underlying exe - with those at symlink location earlier in the list + #review - a user may have other expectations. + + #case differences could represent different paths on unix-like platforms. + #It's perhaps a little unwise to configure matching paths with only case differences for a cross-platform tool .. but we should support it for those who use it and have no interest in windows - todo! review + if {"dev" in $package_modes} { + set normexe_dir [file dirname $normexe] + if {[file tail $normexe_dir] eq "bin"} { + #underlying exe in a bin dir - backtrack 1 + lappend exe_module_folders [file dirname $normexe_dir]/modules + lappend exe_module_folders [file dirname $normexe_dir]/modules_tcl$tclmajorv + } else { + lappend exe_module_folders $normexe_dir/modules + lappend exe_module_folders $normexe_dir/modules_tcl$tclmajorv + } + set nameexe_dir [file dirname [file normalize [info nameofexecutable]]] ;#must be normalized for capitalisation consistency + + #possible symlink (may resolve to same path as above - we check below to not add in twice) + if {[file tail $nameexe_dir] eq "bin"} { + lappend exe_module_folders [file dirname $nameexe_dir]/modules + lappend exe_module_folders [file dirname $nameexe_dir]/modules_tcl$tclmajorv + } else { + lappend exe_module_folders $nameexe_dir/modules + lappend exe_module_folders $nameexe_dir/modules_tcl$tclmajorv + } + + #foreach modulefolder $exe_module_folders { + # set lc_external_tm_dirs [string tolower $external_tm_dirs] + # set lc_modulefolder [string tolower $modulefolder] + # if {$lc_modulefolder in [string tolower $original_external_tm_dirs]} { + # #perhaps we have an env var set pointing to one of our dev foldersl. We don't want to rely on how the kit ordered it. + # #bring to front if not already there. + # #assert it must be present in $lc_external_tm_dirs if it's in $original_external_tm_dirs + # set posn [lsearch $lc_external_tm_dirs $lc_modulefolder] + # if {$posn > 0} { + # #don't rely on lremove here. Not all runtimes have it and we don't want to load our forward-compatibility packages yet. + # #(still need to support tcl 8.6 - and this script used in multiple kits) + # set external_tm_dirs [lreplace $external_tm_dirs $posn $posn] + # #don't even add it back in if it doesn't exist in filesystem + # if {[file isdirectory $modulefolder]} { + # set external_tm_dirs [linsert $external_tm_dirs 0 $modulefolder] + # } + # } + # } else { + # if {$lc_modulefolder ni $lc_external_tm_dirs && [file isdirectory $modulefolder]} { + # set external_tm_dirs [linsert $external_tm_dirs 0 $modulefolder] ;#linsert seems faster than 'concat [list $modulefolder] $external_tm_dirs' - review + # } + # } + #} + if {![llength $exe_module_folders]} { + puts stderr "Warning - no 'modules' or 'modules_tcl$tclmajorv' folders found relative to executable (or it's symlink if any)" + } else { + set tm_additions_dev $exe_module_folders + } + } + + + + + if {"os" in $package_modes} { + #2) support developer running from a folder containing *.tm files they want to make available + # could cause problems if user happens to be in a subdirectory of a tm folder structure as namespaced modules won't work if not at a tm path root. + #The current dir could also be a subdirectory of an existing tm_dir which would fail during tcl::tm::add - we will need to wrap all additions in catch + set currentdir_modules [glob -nocomplain -dir [pwd] -type f -tail *.tm] + #we assume [pwd] will always return an external (not kit) path at this point - REVIEW + if {[llength $currentdir_modules]} { + #now add current dir (if no conflict with above) + set external_tm_dirs [linsert $external_tm_dirs 0 $currentdir_modules] + if {[file exists [pwd]/modules] || [file exists [pwd]/modules_tcl$tclmajorv]} { + puts stderr "WARNING: modules or modules_tcl$tclmajorv folders not added to tcl::tm::path due to modules found in current workding dir [pwd]" + } + } else { + #modules or modules_tclX subdir relative to cwd cannot be added if [pwd] has been added + set cwd_modules_folder [file join [pwd] modules] ;#pwd is already normalized to appropriate capitalisation + if {[file isdirectory $cwd_modules_folder]} { + if {[string tolower $cwd_modules_folder] ni [string tolower $external_tm_dirs]} { + #prepend + set external_tm_dirs [linsert $external_tm_dirs 0 $cwd_modules_folder] + } + } + set cwd_modules_folder [file join [pwd] modules_tcl$tclmajorv] + if {[file isdirectory $cwd_modules_folder]} { + if {[string tolower $cwd_modules_folder] ni [string tolower $external_tm_dirs]} { + #prepend + set external_tm_dirs [linsert $external_tm_dirs 0 $cwd_modules_folder] + } + } + } + } + + #assert tcl::tm::list still empty here + #restore module paths + # -- --- --- --- --- --- --- --- + set new_tm_path [list] + foreach mode $package_modes { + switch -exact -- $mode { + internal { + #review + #even though the internal_tm_dirs came from either ::env or the executable's init - we don't treat them as 'os' paths + #Add them before our own internal additions + foreach n $internal_tm_dirs { + if {$n ni $new_tm_path} { + lappend new_tm_path $n + } + } + foreach n $tm_additions_internal { + if {$n ni $new_tm_path} { + lappend new_tm_path $n + } + } + } + dev { + foreach n $tm_additions_dev { + if {$n ni $new_tm_path} { + lappend new_tm_path $n + } + } + } + os { + foreach n $external_tm_dirs { + if {$n ni $new_tm_path} { + lappend new_tm_path $n + } + } + } + } + } + foreach p [lreverse $new_tm_path] { + if {[catch {tcl::tm::add $p} errM]} { + puts stderr "Failed to add tm module dir '$p' to tcl::tm::list\n$errM" + } + } + + + + + + ##tcl::tm::add internals first (so they end up at the end of the tmlist) as in 'dev' mode (dev as first argument on launch) we preference external modules + ##note use of lreverse to maintain same order + #foreach p [lreverse $internal_tm_dirs] { + # if {$p ni [tcl::tm::list]} { + # #Items that end up at the beginning of the tm list are processed first.. but an item of same version later in the tm list will not override the ifneeded script of an already encountered .tm. + # #addition can fail if one path is a prefix of another + # if {[catch {tcl::tm::add $p} errM]} { + # puts stderr "Failed to add internal module dir '$p' to tcl::tm::list\n$errM" + # } + # } + #} + ##push externals to *head* of tcl::tm::list - as they have priority + #foreach p [lreverse $external_tm_dirs] { + # if {$p ni [tcl::tm::list]} { + # if {[catch {tcl::tm::add $p} errM]} { + # puts stderr "Failed to add external module dir '$p' to tcl::tm::list\n$errM" + # } + # } + #} + + #AUTO_PATH + + + #auto_path - add *external* exe-relative after exe-relative path + #add lib and lib_tcl8 lib_tcl9 etc based on tclmajorv + #libs appended to end of ::auto_path are processed first (reverse order processing in 'package unknown'), but ifneeded scripts are overridden by earlier ones + #(ie for both tcl::tm::list and auto_path it is priority by 'order of appearance' in the resultant lists - not the order in which they are added to the lists) + # + + #we can't rely on builtin ledit (tcl9+) or loadable version such as punk::lib::compat::ledit at this point + #so we prepend to auto_path using a slightly inefficient method. Should be fine on relatively small list like this + #eventually it should just be something like 'ledit ::auto_path -1 -1 $libfolder' + if {"dev" in $package_modes} { + set platform [::punkboot::platform_generic] + #on windows - case differences dont matter - but can stop us finding path in auto_path + #on other platforms, case differences could represent different paths + #review + set process_folders [list] + foreach libsub [list lib_tcl$tclmajorv lib] { + if {[file tail $nameexe_dir] eq "bin"} { + set libfolder [file dirname $nameexe_dir]/$libsub + } else { + set libfolder $nameexe_dir/$libsub + } + if {[file isdirectory $libfolder]} { + #lappend auto_path_additions_dev $libfolder + lappend process_folders $libfolder + } + + # ------------- + if {[file tail $normexe_dir] eq "bin"} { + set libfolder [file dirname $normexe_dir]/$libsub + } else { + set libfolder $normexe_dir/$libsub + } + if {[file isdirectory $libfolder]} { + #lappend auto_path_additions_dev $libfolder + if {$libfolder ni $process_folders} { + lappend process_folders $libfolder + } + } + # ------------- + set libfolder [pwd]/$libsub + if {[file isdirectory $libfolder]} { + #lappend auto_path_additions_dev $libfolder + if {$libfolder ni $process_folders} { + lappend process_folders $libfolder + } + } + } + foreach f $process_folders { + if {[string match lib_tcl* [file tail $f]]} { + if {[file exists $f/allplatforms]} { + lappend auto_path_additions_dev $f/allplatforms + } + if {[file exists $f/$platform]} { + lappend auto_path_additions_dev $f/$platform + } + } else { + lappend auto_path_additions_dev $f + } + } + + } + # -- --- --- --- --- --- --- --- + #split existing ::auto_path entries into internal & external + set internal_ap_dirs [list] ;# + set external_ap_dirs [list] + set lcase_internal_paths [string tolower $internal_paths] + foreach pkgpath $::auto_path { + set pkgpathlower [string tolower $pkgpath] + set is_internal 0 + foreach okprefix $lcase_internal_paths { + if {[string match "$okprefix*" $pkgpathlower]} { + lappend internal_ap_dirs $pkgpath + set is_internal 1 + break + } + } + if {!$is_internal} { + lappend external_ap_dirs $pkgpath + } + } + # -- --- --- --- --- --- --- --- + set new_auto_path [list] + foreach mode $package_modes { + switch -exact -- $mode { + internal { + #review + #even though the internal_ap_dirs came from either ::env or the executable's init - we don't treat them as 'os' paths + #Add them before our own internal additions + foreach n $internal_ap_dirs { + if {$n ni $new_auto_path} { + lappend new_auto_path $n + } + } + foreach n $auto_path_additions_internal { + if {$n ni $new_auto_path} { + lappend new_auto_path $n + } + } + } + dev { + foreach n $auto_path_additions_dev { + if {$n ni $new_auto_path} { + lappend new_auto_path $n + } + } + } + os { + foreach n $external_ap_dirs { + if {$n ni $new_auto_path} { + lappend new_auto_path $n + } + } + } + } + } + set ::auto_path $new_auto_path + + } else { + #package_mode 'internal' only + #Tcl_Init will most likely have set up some external paths + #As our app has been started without first arg (package_mode) indicating anything other than 'internal' - we will prune paths that are not zipfs or tclkit + #(or set via punkboot::internal_paths) + set filtered_auto_path [list] + #review - case insensitive ok for windows - but could cause issues on other platforms? + foreach ap $::auto_path { + set aplower [string tolower $ap] + foreach okprefix $internal_paths { + if {[string match "[string tolower $okprefix]*" $aplower]} { + lappend filtered_auto_path $ap + break + } + } + } + #puts stderr "main.tcl internal_paths: $internal_paths" + #puts stderr "main.tcl filtered_auto_path: $filtered_auto_path" + + set filtered_tm_list [list] + foreach tm [tcl::tm::list] { + set tmlower [string tolower $tm] + foreach okprefix $internal_paths { + if {[string match "[string tolower $okprefix]*" $tmlower]} { + lappend filtered_tm_list $tm + break + } + } + } + set new_tm_list [list] + foreach p $filtered_tm_list { + if {$p ni $new_tm_list && [file exists $p]} { + lappend new_tm_list $p + } + } + foreach p $tm_additions_internal { + if {$p ni $new_tm_list && [file exists $p]} { + lappend new_tm_list $p + } + } + tcl::tm::remove {*}[tcl::tm::list] + tcl::tm::add {*}[lreverse $new_tm_list] + + + #If it looks like we are running the vfs/_build/exename.vfs/main.tcl from an external tclsh - try to use vfs folders to simulate kit state + #set script_relative_lib [file normalize [file join [file dirname [info script]] lib]] + #set scriptdir [file dirname [info script]] + set scriptdir [file dirname $normscript] + if {![string match //zipfs:/* $scriptdir] && ![string match "${cookbase}*" $scriptdir] && ![info exists ::tcl::kitpath]} { + #presumably running the vfs/xxx.vfs/main.tcl script using a non-kit tclsh that doesn't have starkit lib or mounted zipfs/cookfs available.. lets see if we can move forward anyway + set vfscontainer [file normalize [file dirname $scriptdir]] + #set vfscommon [file join $vfscontainer _vfscommon] + #we shouldn't be targetting the src/vfs folders - use src/_build/exename.vfs instead + set vfsdir [file normalize $scriptdir] + set projectroot [file dirname [file dirname $vfscontainer]] ;#back below src/_build/exename.vfs/main.tcl + puts stdout "no starkit. projectroot?: $projectroot executable:[info nameofexecutable]" + puts stdout "info lib: [info library]" + + #add back the info lib reported by the executable.. as we can't access the one built into a kit + if {[file exists [info library]]} { + if {[string tolower [info library]] ni [string tolower [list {*}$filtered_auto_path {*}$auto_path_additions_internal]]} { + lappend auto_path_additions_internal [info library] + } + } + + set lib_types [list lib lib_tcl$tclmajorv] + foreach l $lib_types { + set lib [file join $vfsdir $l] + if {[file exists $lib] && [string tolower $lib] ni [string tolower [list {*}$filtered_auto_path {*}$auto_path_additions_internal]]} { + lappend auto_path_additions_internal $lib + } + } + #foreach l $lib_types { + # set lib [file join $vfscommon $l] + # if {[file exists $lib] && [string tolower $lib] ni [string tolower $::auto_path]} { + # lappend ::auto_path $lib + # } + #} + set ::auto_path [list {*}$filtered_auto_path {*}$auto_path_additions_internal] + puts stderr "main.tcl final auto_path: $::auto_path" + + + + set mod_types [list modules modules_tcl$tclmajorv] + foreach m $mod_types { + set modpath [file join $vfsdir $m] + if {[file exists $modpath] && [string tolower $modpath] ni [string tolower [tcl::tm::list]]} { + tcl::tm::add $modpath + } + } + #foreach m $mod_types { + # set modpath [file join $vfscommon $m] + # if {[file exists $modpath] && [string tolower $modpath] ni [string tolower [tcl::tm::list]]} { + # tcl::tm::add $modpath + # } + #} + } else { + #normal case main.tcl from vfs + set ::auto_path [list {*}$filtered_auto_path {*}$auto_path_additions_internal] + } + #force rescan + #catch {package require flobrudder666_nonexistant} + #puts stderr "main.tcl auto_path :$::auto_path" + #puts stderr "main.tcl tcl::tm::list:[tcl::tm::list]" + } + + + + #-------------------------------------------------------- + #load libunknown without triggering the existing package unknown + #maint: also in punk::repl package + #-------------------------------------------------------- + set libunks [list] + foreach tm_path [tcl::tm::list] { + set punkdir [file join $tm_path punk] + if {![file exists $punkdir]} {continue} + lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] + } + set libunknown "" + set libunknown_version_sofar "" + foreach lib $libunks { + #expecting to be of form libunknown-.tm + set vtail [lindex [split [file tail $lib] -] 1] + set thisver [file rootname $vtail] ;#file rootname x.y.z.tm + if {$libunknown_version_sofar eq ""} { + set libunknown_version_sofar $thisver + set libunknown $lib + } else { + if {[package vcompare $thisver $libunknown_version_sofar] == 1} { + set libunknown_version_sofar $thisver + set libunknown $lib + } + } + } + if {$libunknown ne ""} { + source $libunknown + if {[catch {punk::libunknown::init -caller main.tcl} errM]} { + puts "error initialising punk::libunknown\n$errM" + } + } + #-------------------------------------------------------- + #Now that new 'package unknown' mechanism is in place - we can use package require + + + #assert arglist has had 'dev|os|os-dev etc' first arg removed if it was present. + if {[llength $arglist] == 1 && [lindex $arglist 0] eq "tclsh"} { + #called as dev tclsh or tclsh + #we would like to drop through to standard tclsh repl without launching another process + #tclMain.c doesn't allow it unless patched. + if {![info exists ::env(TCLSH_PIPEREPL)]} { + set is_tclsh_piperepl_env_true 0 + } else { + if {[string is boolean -strict $::env(TCLSH_PIPEREPL)]} { + set is_tclsh_piperepl_env_true $::env(TCLSH_PIPEREPL) + } else { + set is_tclsh_piperepl_env_true 0 + } + } + if {!$is_tclsh_piperepl_env_true} { + puts stderr "tcl_interactive: $::tcl_interactive" + puts stderr "stdin: [chan configure stdin]" + puts stderr "Environment variable TCLSH_PIPEREPL is not set or is false or is not a boolean" + } else { + #according to env TCLSH_PIPEREPL and our commandline argument - tclsh repl is desired + #check if tclsh/punk has had the piperepl patch applied - in which case tclsh(istty) should exist + if {![info exists ::tclsh(istty)]} { + puts stderr "error: the runtime doesn't appear to have been compiled with the piperepl patch" + } + } + set ::tcl_interactive 1 + set ::tclsh(dorepl) 1 + } else { + package require app-project + } +}} {*}$::argv diff --git a/src/project_layouts/vendor/punk/project-0.1/src/vfs/sample.vfs/main.tcl#..+_config+project_main.tcl#@punk%3a%3aboot,merge_over#.fxlnk b/src/project_layouts/vendor/punk/project-0.1/src/vfs/sample.vfs/main.tcl#..+_config+project_main.tcl#@punk%3a%3aboot,merge_over#.fxlnk new file mode 100644 index 00000000..e69de29b diff --git a/src/vfs/_vfscommon.vfs/lib/app-punkshell/punkshell.tcl b/src/vfs/_vfscommon.vfs/lib/app-punkshell/punkshell.tcl index 828d6da8..515e8c10 100644 --- a/src/vfs/_vfscommon.vfs/lib/app-punkshell/punkshell.tcl +++ b/src/vfs/_vfscommon.vfs/lib/app-punkshell/punkshell.tcl @@ -248,10 +248,97 @@ dict with prevglobal {} set exitinfo [dict create] switch -glob -nocase -- $script_or_kit { lib:* { + set exitinfo {} #scriptlib - puts stderr "lib:* todo" + #There may be one or more colons after lib + set cposn [string first : $script_or_kit] + set script_or_kit [string trimleft [string range $script_or_kit $cposn+1 end] :] + if {[file pathtype $script_or_kit] eq "relative"} { + set has_globchars [regexp {[*?]} $script_or_kit] ;#basic globs only? + + + set exepath [file dirname [file normalize [file join [info nameofexecutable] ___]]] ;#symlink resolve - review should we resolve scriptlib relative to a symlink too? + set kit_libdir "" ;#metakit or zipkit libdir + set known_extensions [list .tcl .py .pl .ps1 .sh] ;#review + set ext [file extension $script_or_kit] + if {[string tolower $ext] ni $known_extensions} { + #only .tcl scripts allowed to be called extensionlessly + set scriptname $script_or_kit.tcl + } else { + set scriptname $script_or_kit + } + set lower_ext [string tolower [file extension $scriptname]] + if {$lower_ext in {.tcl .kit}} { + set has_zipfs_command [expr {[info commands ::tcl::zipfs::root] ne ""}] + set kit_base "" + if {$has_zipfs_command && [file exists [tcl::zipfs::root]]} { + set kit_base [tcl::zipfs::root] + } elseif {[file type $exepath] eq "directory"} { + set kit_base $exepath + } + if {$has_zipfs_command && [file exists $kit_base/app/scriptlib]} { + set kit_libdir $kit_base/app/scriptlib + } elseif {[file exists $exepath/scriptlib]} { + set kit_libdir $exepath/scriptlib + } + + #partly for performance benefit - we don't allow overriding of vfs internal scripts. + #Only additional scripts can be provided by the bin/scriptlib or ../bin/scriptlib folders + if {$kit_libdir ne "" && [file exists $kit_libdir/$scriptname]} { + switch -- $lower_ext { + .tcl { + set exitinfo [punkshell::do_script $kit_libdir/$scriptname {*}$arglist] + } + .kit { + set exitinfo [punkshell::do_tclkit $kit_libdir/$scriptname "no_repl" {*}$arglist] + } + } + } else { + #fallback to external filesystem + set exedir [file dirname $exepath] + set bin_scripts [file join $exedir scriptlib] + set binsibling_scripts [file join [file dirname $exedir] scriptlib] + set script_check_paths [list] + if {[file exists $bin_scripts]} { + lappend script_check_paths $bin_scripts/$scriptname + } + if {[file exists $binsibling_scripts]} { + lappend script_check_paths $binsibling_scripts/$scriptname + } + if {[llength $script_check_paths]} { + foreach check_path $script_check_paths { + if {[file exists $check_path]} { + switch -- $lower_ext { + .tcl { + set exitinfo [punkshell::do_script $check_path {*}$arglist] + } + .kit { + set exitinfo [punkshell::do_tclkit $check_path "no_repl" {*}$arglist] + } + } + break + } + } + } else { + puts stderr "script $script_or_kit not found in vfs or in filesystem relative to $exedir" + puts stderr "valid locations:" + if {$kit_base ne ""} { + puts stderr " $kit_base/scriptlib/$scriptname" + } + puts stderr " $bin_scripts/$scriptname" + puts stderr " $binsibling_scripts/$scriptname" + } + } + } else { + puts stderr "No current support for extension [file extension $scriptname]" + } + + } else { + puts stderr "Path supplied to lib: must be a relative path" + } } *.tcl { + #except for lib:*.tcl set exitinfo [punkshell::do_script $script_or_kit {*}$arglist] } *.kit { diff --git a/src/vfs/_vfscommon.vfs/lib/app-shellspy/shellspy.tcl b/src/vfs/_vfscommon.vfs/lib/app-shellspy/shellspy.tcl index 2994077e..7c4a3044 100644 --- a/src/vfs/_vfscommon.vfs/lib/app-shellspy/shellspy.tcl +++ b/src/vfs/_vfscommon.vfs/lib/app-shellspy/shellspy.tcl @@ -33,9 +33,9 @@ set arg1 [lindex $::argv 0] if {[file extension $arg1] in [list .tCl]} { set ::argv [lrange $::argv 1 end] set ::argc [llength $::argv] - + set exedir [file dirname [info nameofexecutable]] - set binscripts [file join $exedir scriptlib] + set binscripts [file join $exedir scriptlib] if {[file exists $binscripts]} { set libdir $binscripts } else { diff --git a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm index 1e09252d..6bf529eb 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm @@ -6321,7 +6321,10 @@ namespace eval punk { #useful for aliases e.g treemore -> xmore tree proc xmore {args} { if {[llength $args]} { - uplevel #0 [list {*}$args | more] + #more is older and not as featureful as less + #more importantly - at least some implementations (msys on windows) can skip output lines - unknown as to why + #uplevel #0 [list {*}$args | more] + uplevel #0 [list {*}$args | less -X] ;#-X to avoid use of alternate-screen } else { error "usage: punk::xmore args where args are run as {*}\$args | more" } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm index ad2d58f4..15421402 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm @@ -3130,10 +3130,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } undt { - #CSI 58:5 UNDERLINE COLOR PALETTE INDEX - #CSI 58 : 5 : INDEX m - #variable TERM_colour_map - #256 colour underline by Xterm name or by integer + # CSI 58:5 UNDERLINE COLOR PALETTE INDEX + # CSI 58 : 5 : INDEX m + # variable TERM_colour_map + # 256 colour underline by Xterm name or by integer #name is xterm name or colour index from 0 - 255 set cc [tcl::string::tolower [tcl::string::range $i 5 end]] if {[tcl::string::is integer -strict $cc] & $cc < 256} { @@ -5202,9 +5202,10 @@ tcl::namespace::eval punk::ansi { #tcl::dict::set codestate_empty undersingle "" #tcl::dict::set codestate_empty underdouble "" #tcl::dict::set codestate_empty undercurly "" - #tcl::dict::set codestate_empty underdottedn "" + #tcl::dict::set codestate_empty underdotted "" #tcl::dict::set codestate_empty underdashed "" + tcl::dict::set codestate_empty blink "" ;#5 or 6 for slow/fast, 25 for off tcl::dict::set codestate_empty reverse "" ;#7 on 27 off tcl::dict::set codestate_empty hide "" ;#8 on 28 off @@ -5234,6 +5235,8 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate_empty fg "" ;#30-37 + 90-97 tcl::dict::set codestate_empty bg "" ;#40-47 + 100-107 + variable metastate_empty + tcl::dict::set metastate_empty underline_active "" ;#a meta state for whether underlines are on|off - values 1,0,"" #misnomer should have been sgr_merge_args ? :/ #as a common case optimisation - it will not merge a single element list, even if that code contains redundant elements @@ -5269,6 +5272,7 @@ tcl::namespace::eval punk::ansi { #(use punk::ansi::ta::split_codes_single) proc sgr_merge_singles {codelist args} { variable codestate_empty + variable metastate_empty variable defaultopts_sgr_merge_singles set opts $defaultopts_sgr_merge_singles foreach {k v} $args { @@ -5284,8 +5288,8 @@ tcl::namespace::eval punk::ansi { } set othercodes [list] - set codestate $codestate_empty - set codestate_initial $codestate_empty ;#keep a copy for resets. + set codestate $codestate_empty ;#take copy as we need the empty state for resets + set metastate $metastate_empty set did_reset 0 #we should also handle 8bit CSI here? mixed \x1b\[ and \x9b ? Which should be used in the merged result? @@ -5345,7 +5349,8 @@ tcl::namespace::eval punk::ansi { switch -- $codeint { "" - 0 { if {![tcl::dict::get $opts -filter_reset]} { - set codestate $codestate_initial + set codestate $codestate_empty + set metastate $metastate_empty set did_reset 1 } } @@ -5371,27 +5376,42 @@ tcl::namespace::eval punk::ansi { #e.g hyper on windows if {[llength $paramsplit] == 1} { tcl::dict::set codestate underline 4 + if {[tcl::dict::get $codestate underextended] eq "4:0"} { + tcl::dict::set codestate underextended "" + } + tcl::dict::set metastate underline_active 1 } else { switch -- [lindex $paramsplit 1] { 0 { #no *extended* underline #tcl::dict::set codestate underline 24 tcl::dict::set codestate underextended 4:0 ;#will not turn off SGR standard underline if term doesn't support extended + tcl::dict::set metastate underline_active 0 } 1 { + #single tcl::dict::set codestate underextended 4:1 + tcl::dict::set metastate underline_active 1 } 2 { + #double tcl::dict::set codestate underextended 4:2 + tcl::dict::set metastate underline_active 1 } 3 { + #curly tcl::dict::set codestate underextended "4:3" + tcl::dict::set metastate underline_active 1 } 4 { + #dotted tcl::dict::set codestate underextended "4:4" + tcl::dict::set metastate underline_active 1 } 5 { + #dashed tcl::dict::set codestate underextended "4:5" + tcl::dict::set metastate underline_active 1 } } @@ -5431,6 +5451,7 @@ tcl::namespace::eval punk::ansi { 24 { tcl::dict::set codestate underline 24 ;#off tcl::dict::set codestate underextended "4:0" ;#review + tcl::dict::set metastate underline_active 0 } 25 { tcl::dict::set codestate blink 25 ;#off @@ -5519,11 +5540,11 @@ tcl::namespace::eval punk::ansi { } 58 { #nonstandard - #256 colour or rgb + # 256 colour or rgb if {[tcl::string::first : $p] < 0} { switch -- [lindex $plist $i+1] { 5 { - #256 - 1 more param + # 256 - 1 more param tcl::dict::set codestate underlinecolour "58\;5\;[lindex $plist $i+2]" incr i 2 } @@ -5544,10 +5565,12 @@ tcl::namespace::eval punk::ansi { 60 { tcl::dict::set codestate ideogram_underline 60 tcl::dict::set codestate ideogram_clear "" + #nounderline effect? review! } 61 { tcl::dict::set codestate ideogram_doubleunderline 61 tcl::dict::set codestate ideogram_clear "" + #nounderline effect? review! } 62 { tcl::dict::set codestate ideogram_overline 62 @@ -5566,6 +5589,7 @@ tcl::namespace::eval punk::ansi { #review - we still need to pass through the ideogram_clear in case something understands it tcl::dict::set codestate ideogram_underline "" tcl::dict::set codestate ideogram_doubleunderline "" + tcl::dict::set codestate ideogram_overline "" tcl::dict::set codestate ideogram_doubleoverline "" } @@ -5623,6 +5647,7 @@ tcl::namespace::eval punk::ansi { } } underlinecolour - underextended { + #review append unmergeable "${v}\;" } default { @@ -5640,7 +5665,11 @@ tcl::namespace::eval punk::ansi { "" {} default { switch -- $k { - underlinecolour - underextended { + underlinecolour { + append unmergeable "${v}\;" + } + underextended { + #review append unmergeable "${v}\;" } default { diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.tm index 7b6ee228..d8c43c45 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.tm @@ -3608,7 +3608,12 @@ tcl::namespace::eval punk::args { #A_PREFIX can resolve to empty string if colour off #we then want to display underline instead set A_PREFIX [a+ underline] - set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + #set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space (zwsp) + set A_PREFIXEND [a+ nounderline] + #review - zwsp problematic on older terminals that print it visibly + #- especially if they also lie about cursor position after it's emitted. + #so although the zwsp fixes the issue where the underline extends to rhs padding if all text was underlined, + #It's probably best fixed in the padding functionality. } else { set A_PREFIXEND $RST } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm index 8634b4ec..b8b56d23 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm @@ -211,9 +211,9 @@ namespace eval punk::console { set result [dict create] if {"output" in $channels} { #note setting stdout makes stderr have the same settings - ie there is really only one output to configure - set h_out [twapi::get_console_handle stdout] + set h_out [twapi::get_console_handle stdout] set oldmode [twapi::GetConsoleMode $h_out] - set newmode [expr {$oldmode | 4}] + set newmode [expr {$oldmode | 4}] twapi::SetConsoleMode $h_out $newmode dict set result output [list from $oldmode to $newmode] } @@ -255,7 +255,7 @@ namespace eval punk::console { #as above - configuring stdout does stderr too set h_out [twapi::get_console_handle stdout] set oldmode [twapi::GetConsoleMode $h_out] - set newmode [expr {$oldmode & ~4}] + set newmode [expr {$oldmode & ~4}] twapi::SetConsoleMode $h_out $newmode dict set result output [list from $oldmode to $newmode] } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm index 17c9918b..ad60b069 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm @@ -507,6 +507,7 @@ namespace eval punk::mix::cli { -punkcheck_eventobj "\uFFFF"\ -glob *.tm\ -podglob #modpod-*\ + -tarjarglob #tarjar-*\ ] set opts [dict merge $defaults $args] @@ -519,6 +520,7 @@ namespace eval punk::mix::cli { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set fileglob [dict get $opts -glob] set podglob [dict get $opts -podglob] + set tarjarglob [dict get $opts -tarjarglob] if {![string match "*.tm" $fileglob]} { error "build_modules_from_source_to_base -glob '$fileglob' doesn't seem to target tcl modules." } @@ -580,6 +582,10 @@ namespace eval punk::mix::cli { foreach podpath $src_pods { dict set process_modules $podpath [dict create -type pod] } + set src_tarjars [glob -nocomplain -dir $current_source_dir -type d -tail $tarjarglob] + foreach tarjarpath $src_tarjars { + dict set process_modules $tarjarpath [dict create -type tarjar] + } 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] @@ -801,8 +807,173 @@ namespace eval punk::mix::cli { } } tarjar { + #maint - overall code structure same as pod - refactor? #basename may still contain #tarjar- #to be obsoleted - update modpod to (optionally) use vfs::tar ? + if {[string match #tarjar-* $basename]} { + set basename [string range $basename 8 end] + } else { + error "build_modules_from_source_to_base, tarjar, unexpected basename $basename" ;#shouldn't be possible with default tarjarglob - review - why is tarjarglob 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\ + ] + set had_error 0 + + # -max_depth -1 for no limit + set build_installername tarjars_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/#tarjar-$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/#tarjar-$basename-$module_build_version/#tarjar-loadscript-$basename.tcl + #we don't need to modify version or name of the loadscript + #just do basic sanity check that the file exists + if {![file exists $tmfile]} { + set had_error 1 + lappend notes "tarjar_loadscript_missing" + } + } + #delete and regenerate .tm + set notes [list] + if {[catch { + file delete $buildfolder/$basename-$module_build_version.tm + } err]} { + set had_error 1 + lappend notes "tm_delete_failed" + } + #create ordinary tar file without using external executable + package require tar ;#tcllib + set tarfile $buildfolder/$basename-$module_build_version.tm ;#ordinary tar file (no compression - store) + set wd [pwd] + cd $buildfolder + puts "tar::create $tarfile #tarjar-$basename-$module_build_version" + if {[catch { + tar::create $tarfile #tarjar-$basename-$module_build_version + } errMsg]} { + set had_error 1 + puts stderr "tar::create $tarfile failed with msg\n $errMsg" + lappend notes "tar_create_failed" + } + cd $wd + + if {![file exists $tarfile]} { + set had_error 1 + lappend notes "tar_result_missing" + } + + + 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 "T" + 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 + + #JMN - review + if {!$had_error} { + $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 + if {[catch { + file copy -force $modulefile $target_module_dir + } errMsg]} { + puts stderr "FAILED to copy tarjar module $modulefile to $target_module_dir" + $event targetset_end FAILED -note "could not copy $modulefile" + } else { + puts stderr "Copied tarjar module $modulefile to $target_module_dir" + # -- --- --- --- --- --- + $event targetset_end OK -note "tarjar" + } + } else { + puts -nonewline stderr "t" + set did_skip 1 + if {$is_interesting} { + puts stderr "$modulefile [$event targetset_source_changes]" + } + $event targetset_end SKIPPED + } + } } file { @@ -829,39 +1000,40 @@ namespace eval punk::mix::cli { if {[file exists $current_source_dir/#tarjar-$basename-$magicversion]} { - #rebuild the .tm from the #tarjar + #rebuilding the .tm from the #tarjar already handled above + puts -nonewline stderr "-" - if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} { + #if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} { - } else { + #} else { - } - #REVIEW - should be in same structure/depth as $target_module_dir in _build? + #} + ##REVIEW - should be in same structure/depth as $target_module_dir in _build? - #TODO - set buildfolder $current_sourcedir/_build - file mkdir $buildfolder + ##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 + #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 + #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 + #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}#]} { diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm index e899a401..3de09e5e 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm @@ -73,7 +73,7 @@ tcl::namespace::eval punk::ns { set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $ns_current *]] } else { set is_absolute [string match ::* $ns_or_glob] - set has_globchars [regexp {[*?]} $ns_or_glob] + set has_globchars [regexp {[*?]} $ns_or_glob] ;#basic globs only? if {$is_absolute} { if {!$has_globchars} { if {![nsexists $ns_or_glob]} { @@ -747,7 +747,13 @@ tcl::namespace::eval punk::ns { return $nslist } - variable usageinfo_char \U1f6c8 + #The information symbol - usually i in a circle + #punkargs " symbol \U1f6c8" ;#problematic on terminals that lie about cursor position after emitting this character + #The older \u2139 could be used - but it is sometimes a boxed i, sometimes a bold stylized i, sometimes a pre-coloured boxed i + #\u24d8 (circled latein small letter i) seems more consistent and can have our own colour applied. + #variable usageinfo_char \U1f6c8 + variable usageinfo_char \u24d8 + # command has usageinfo e.g from punk::args. todo cmdline, argp, tepam etc? proc Usageinfo_mark {{ansicodes \UFFEF}} { variable usageinfo_char @@ -760,6 +766,7 @@ tcl::namespace::eval punk::ns { } } + punk::args::define { @id -id ::punk::ns::Cmark @cmd -name punk::ns::Cmark @@ -768,7 +775,7 @@ tcl::namespace::eval punk::ns { oo " symbol \u25c6" ooc " symbol \u25c7" ooo " symbol \u25c8" - punkargs " symbol \U1f6c8" + punkargs " symbol \u24d8" ensemble " symbol \u24ba" native " symbol \u24c3" unknown " symbol \u2370" @@ -797,7 +804,7 @@ tcl::namespace::eval punk::ns { return; #should be unreachable - parse should raise usage error } } - set marks [dict create oo \u25c6 ooc \u25c7 ooo \u25c8 punkargs \U1f6c8 ensemble \u24ba native \u24c3 unknown \U2370] + set marks [dict create oo \u25c6 ooc \u25c7 ooo \u25c8 punkargs \u24d8 ensemble \u24ba native \u24c3 unknown \U2370] if {[llength $ansinames]} { return "[punk::ansi::a+ {*}$ansinames][dict get $marks $type]\x1b\[0m" } else { diff --git a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm index 11cd9706..7d93d529 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm @@ -1876,7 +1876,9 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #ctrl-c if {$chunk eq "\x03"} { #::punk::repl::handler_console_control "ctrl-c_via_rawloop" - error "character 03 -> ctrl-c" + puts stderr "ctrl-c via rawloop - not signal" + ::punk::repl::handler_console_control ctrl-c via_rawloop + #error "character 03 -> ctrl-c" } if {$chunk eq "\x7f"} { @@ -1898,8 +1900,9 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #for now - exit with small delay for tidyup #ctrl-z #::punk::repl::handler_console_control "ctrl-z_via_rawloop" - if {[catch {mode line}]} { - interp eval code {mode line} + if {[catch {punk::console::mode line}]} { + #REVIEW + interp eval code {punk::console::mode line} } after 1000 {exit 43} return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/repo-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/repo-0.1.1.tm index 2ab1fb01..5d2a2725 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/repo-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/repo-0.1.1.tm @@ -92,6 +92,9 @@ namespace eval punk::repo { } lappend maincommands {*}$ln } + #fossil output was ordered in columns, but we loaded list in row-wise, messing up the order + set maincommands [lsort $maincommands] + set allcmds [lsort $allcmds] set othercmds [punk::lib::ldiff $allcmds $maincommands] set result "@leaders -min 0\n" diff --git a/src/vfs/_vfscommon.vfs/modules/shellrun-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/shellrun-0.1.1.tm index 8f03892d..478c70fa 100644 --- a/src/vfs/_vfscommon.vfs/modules/shellrun-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/shellrun-0.1.1.tm @@ -222,6 +222,9 @@ namespace eval shellrun { } set resolved_cmdname [auto_execok $cmdname] + if {$resolved_cmdname eq ""} { + error "Cannot find path for executable '$cmdname'" + } set repl_runid [punk::get_repl_runid] #set ::punk::last_run_display [list] diff --git a/src/vfs/_vfscommon.vfs/modules/tarjar-2.3.tm b/src/vfs/_vfscommon.vfs/modules/tarjar-2.3.tm new file mode 100644 index 00000000..3bb1d96b Binary files /dev/null and b/src/vfs/_vfscommon.vfs/modules/tarjar-2.3.tm differ diff --git a/src/vfs/_vfscommon.vfs/modules/test/punk/ansi-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/test/punk/ansi-0.1.1.tm index d41976d8..9fe4f0c3 100644 Binary files a/src/vfs/_vfscommon.vfs/modules/test/punk/ansi-0.1.1.tm and b/src/vfs/_vfscommon.vfs/modules/test/punk/ansi-0.1.1.tm differ diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/Tpt_NoPage.pdf b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/Tpt_NoPage.pdf new file mode 100644 index 00000000..df22a805 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/Tpt_NoPage.pdf @@ -0,0 +1,22 @@ +%PDF-1.7 +%µ¶ + +1 0 obj +<> +endobj + +2 0 obj +<> +endobj + +xref +0 3 +0000000000 00001 f +0000000016 00000 n +0000000062 00000 n + +trailer +<> +startxref +109 +%%EOF diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/class_Doc.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/class_Doc.tcl new file mode 100644 index 00000000..6e75d3f1 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/class_Doc.tcl @@ -0,0 +1,606 @@ +# class_Doc.tcl +# +# Class mupdf::Doc extends class mupdf::Doc_C (implemented in C) + +# - Constructor +# The following commands create a new Doc object +# mupdf::Doc new _filename_ +# mupdf::Doc create id _filename_ +# mupdf::open _filename_ ?-password _pswd_?" +# The recommanded way is to call "mupdf::open" +# +# - Destructor +# $docObj destroy +# $doc quit ;# alias for "$docObj destroy" +# $doc close ;# save all changes and then quit. +# When a document is destroyed, all its related objects (Page, TextSearch, ..) +# are automatically destroyed. +# +# - Methods +# $docObj warnings (* inherithed from Doc_C *) +# $docObj resetwarnings (* inherithed from Doc_C *) +# $docObj wasrepaired (* inherithed from Doc_C *) +# +# $docObj version (* inherithed from Doc_C *) +# $docObj fullname (* inherithed from Doc_C *) +# $docObj authentication (* inherithed from Doc_C *) +# +# $docObj opwd _password_ | "" (* inherithed from Doc_C *) +# $docObj upwd _password_ | "" (* inherithed from Doc_C *) +# $docObj removepassword +# +# $docObj npages (* inherithed from Doc_C *) +# $docObj getpage _n_ +# $docObj ispageopened _n_ +# $docObj openedpages +# $docObj closepage _n_ +# $docObj closallpages +# +# $docObj haschanges (* inherithed from Doc_C *) +# $docObj export _filename_ .... +# +# $docObj fields (* inherithed from Doc_C *) +# $docObj signatures (* inherithed from Doc_C *) +# $docObj addsigfield _fieldname_ .... +# $docObj field _fieldname_ ?_new_value_? +# $docObj flatten _fieldname_ ?_fieldname_ ...? (* inherithed from Doc_C *) +# $docObj fieldattrib _fieldname_ .... (* inherithed from Doc_C *) +# +# $docObj portfolio ... (* inherithed from Doc_C *) +# $docObj anchor _name_ (* inherithed from Doc_C *) +# +# $docObj grafts (* inherithed from Doc_C *) +# $docObj graft $pageObj +# $docObj embed .... +# +# $docObj newsearch ... +# +# $docObj addpage ... +# $docObj deletepage ... +# $docObj deletepages ... +# $docObj movepage ... + + + +oo::class create mupdf::Doc { + superclass mupdf::Doc_C + # hide internal C methods + unexport _RemoveGraftMap + + # has-component publisher .. see constructor + + # OpenedPages is a dictionary listing all the opened pages (pagenumber) + # with their pageObj. + # NOTE that there's a 1:1 relationship between page-numbers and page-objs, + # so this dictionary could have been inverted (i.e exchanged keys with values) + + variable -append OpenedPages + variable -append RelatedDocs + + constructor {args} { + set OpenedPages [dict create] + set RelatedDocs [dict create] + + # create a publisher component and delegate some methods + publisher create [self]::publisher + oo::objdefine [self] forward events [self]::publisher events + oo::objdefine [self] forward register [self]::publisher register + oo::objdefine [self] forward unregister [self]::publisher unregister + + next {*}$args + } + + destructor { + # unregister itself from all RelatedDocs notifications .. + foreach relatedDoc [dict keys $RelatedDocs] { + $relatedDoc unregister * [self] + } + + if { [info object isa object [self]::publisher] } { + [self]::publisher destroy + } + next + } + + method quit {} { + my destroy + } + + # save file before destroyng + method close {} { + if { [my haschanges] } { + set origFilename [my fullname] + # NOTE: you cannot overwrite an opened file, + # therefore save it with a different name (tmpName) + # then close it (quit) and finally rename tmpName + set tmpFilename "${origFilename}.TMP" + my export $tmpFilename + + # since $origFilename is still used by [self], + # a cmd like 'file rename ...' will ALWAYS fail. + # Use 'file copy ..' and this will work unless $origFilename + # is locked by an external app. (e.g. Acrobat) + # ... this kind of error is exactly what we need to solve .. + set res [catch {file copy -force -- $tmpFilename $origFilename} errmsg] + file delete $tmpFilename + if { $res } { + # in case of error, don't quit, propagate the error .. + error $errmsg + } + } + my quit + } + + + method _removeOpenedPageCb {pageObj} { + # do a reverse search, we have the value,, then look for its pagenumber + # note: thisis weird, becuse the page-number of an opened page may change + # due to addpage/deletepage + set pageNum -1 + dict for {k v} $OpenedPages { if {$v eq $pageObj} { set pageNum $k; break } } + if { $k != -1 } { + dict unset OpenedPages $pageNum + } + } + + method getpage {n} { + if { [dict exists $OpenedPages $n] } { + return [dict get $OpenedPages $n] + } + set page [mupdf::Page new [self] $n] + # when this page id destroyed, call _removeOpenedpageCb + $page register !destroyed [self] [oocallback _removeOpenedPageCb $page] + dict set OpenedPages $n $page + return $page + } + +#NEW + # when adding/deleting a page, the OpenedPage dictionary should be updated. + # On addpage: + # *before* adding the new page J, all the keys (pagenumeber) for the opened-pages + # greater-equal than J should be incremented by +1 + # On deletepage: + # *after* deleting the page J, all the keys (pagenumber) for the opened-pages + # greater-equal than J should be incremented by -1 + # NOTE: in this case the key=J (if present) was previosly removed. + # + method _renumberOpenedPagesFrom {J incr} { + dict map {k v} $OpenedPages { + if {$k >= $J} {incr k $incr} + set v $v + } + } + + # + # $pdf addpage _i_ ?-size dx dy? + # if i == "end" --> add after the last page + # + # default size: A4 size (595.0x842.0) + method addpage {args} { + set idx [next {*}$args] ;# .. may raise error + # if it didn't fail, update OpenedPages + set OpenedPages [my _renumberOpenedPagesFrom $idx +1] + return [my getpage $idx] + } + + # $pdf deletepage _i_" + method deletepage {args} { + lassign $args idx + if { [llength $args] != 1 } { + # this is expected to fail, but doing so we get the error message + next {*}$args + # the following command will be never reached because + # we expect the above command will raise an error + error "unexpected behavior in deletepage method" + } + # don't care if it's a good idx or a nonsense string (even an empty string) + if { [my ispageopened $idx] } { + [my getpage $idx] close ;# this will remove $idx from OpenedPages, too. + } + next {*}$args + set OpenedPages [my _renumberOpenedPagesFrom $idx -1] + return + } + + # $pdf deletepages i0 i1" + method deletepages {i0 i1} { + set N [my npages] + incr N -1 + if { ! [string is digit $i0] || $i0 < 0 || $i0 > $N } { error "page number i0 must be between 0 and $N" } + + if { ! [string is digit $i1] || $i1 < 0 || $i1 > $N } { error "page number i1 must be between 0 and $N" } + + for {set i $i0} {$i<=$i1} {incr i} { + my deletepage $i0 ;# always delete page i0, following pages will shift ... + } + } + + # $pdf movepage _from_ _to_ + method movepage {args} { + lassign $args from to + next {*}$args + # trivial case: if from == to, do nothing. + if { $from == $to } return + # save and remove fromPage (if present) + set savedPageObj "" + if { [dict exists $OpenedPages $from] } { + set savedPageObj [dict get $OpenedPages $from] + set OpenedPages [dict remove $OpenedPages $from] + } + set OpenedPages [my _renumberOpenedPagesFrom $from -1] + set OpenedPages [my _renumberOpenedPagesFrom $to +1] + if {$savedPageObj ne ""} { + $savedPageObj close + # we must recreate the opened page with the same name ! + mupdf::Page create $savedPageObj [self] $to + # when this page id destroyed, call _removeOpenedpageCb + $savedPageObj register !destroyed [self] [oocallback _removeOpenedPageCb $savedPageObj] + dict set OpenedPages $to $savedPageObj + } + return + } + + method ispageopened {n} { + dict exists $OpenedPages $n + } + + method openedpages {} { + return [dict keys $OpenedPages] + } + + method closepage {n} { + if { [dict exists $OpenedPages $n] } { + set page [dict get $OpenedPages $n] + $page destroy ;# this will invoke the _removeOpenedPageCb callbak + } + } + + method closeallpages {} { + foreach page [dict values $OpenedPages] { + $page destroy ;# this will invoke the _removeOpenedPageCb callbak + } + } + + method removepassword {} { + my opwd "" + my upwd "" + } + + method export {filename} { + # allow to (try to) export in itself. (this works only in incremental mode) + set filename [file normalize $filename] + if { $filename ne [my fullname] } { + if { $filename in [mupdf::documentnames] } { + error "cannot overwrite an opened PDF-file" + } + } + next $filename + } + + # $pdf field _fieldname_ + # or + # $pdf field _fieldname_ _value_ + method field {fieldname args} { + set value [next $fieldname {*}$args] + # if OK and args != {} i.e. if we updated some fields, then update all the opened pages + if { $args != {} } { + foreach page [dict values $OpenedPages] { + $page _update + } + return + } else { + return $value + } + } + + method flatten {args} { + next {*}$args + foreach page [dict values $OpenedPages] { + $page _update + } + } + + method addsigfield {fieldname pageNum x0 y0 x1 y1} { + next $fieldname $pageNum $x0 $y0 $x1 $y1 + if { [dict exists $OpenedPages $pageNum] } { + set page [dict get $OpenedPages $pageNum] + $page _update + } + } + + method _OnDestroyedRelatedDoc {relatedDoc mapID} { + my _RemoveGraftMap $mapID + dict unset RelatedDocs $relatedDoc + } + + method graft {pageObj} { + try { + set relatedDoc [$pageObj docref] + } on error {} { + error "\"$pageObj\" must be a mupdf::Page" + } + + set relatedDoc [$pageObj docref] + set mapID "GMAP_$relatedDoc" + set graftID [next $pageObj $mapID] + # if everything is OK .. + + # when the relatedDoc will be closed, this mapID can be destroyed. + if { ! [dict exists $RelatedDocs $relatedDoc] } { + dict set RelatedDocs $relatedDoc 1 + $relatedDoc register !destroyed [self] [oocallback _OnDestroyedRelatedDoc $relatedDoc $mapID] + } + return $graftID + } + + method embed {graftKey pageNum args} { + next $graftKey $pageNum {*}$args ;# may raise an error message + if { [dict exists $OpenedPages $pageNum] } { + set page [dict get $OpenedPages $pageNum] + $page _update + } + } + + method newsearch {args} { + mupdf::TextSearch new [self] {*}$args + } + +} + + # add common methods to mupdf::Doc +oo::objdefine mupdf::Doc { mixin mupdf::COMMON_TYPEMETHODS } + + + # --------------------------------------------------------------------------- + # Utilities + # --------------------------------------------------------------------------- + + ## + ## mupdf::printwarnings + ## +namespace eval mupdf { + variable _PRINT_WARNINGS false + + proc printwarnings {args} { + variable _PRINT_WARNINGS + # safe restore in case someone hacked this variable + if { ![info exists _PRINT_WARNINGS] || ! [string is boolean ${_PRINT_WARNINGS}] } { + puts "Warning: missing or bad value for mupdf::_PRINT_WARNINGS. restored to \"true\"" + set _PRINT_WARNINGS true + } + switch -- [llength $args] { + 0 { return ${_PRINT_WARNINGS} } + 1 { + set val [lindex $args 0] + if { $val eq "" || ![string is boolean $val] } { + error "expected boolean value but got \"$val\"" + } + set _PRINT_WARNINGS $val + } + default { + set myName [lindex [info level 0] 0] + error "wrong # args: must be: $myName ?boolean?" + } + } + } +} + + +proc mupdf::open {filename args} { + set usage "mupdf::open filename ?-password pswd?" + while { $args != {} } { + set args [lassign $args arg] + switch -- $arg { + "-password" { + if { $args == {} } { + error "wrong # args: should be \"$usage\"" + } + set args [lassign $args password] + } + default { + error "bad option \"$arg\": should be \"$usage\"" + } + } + } + + set pdf [Doc new $filename] + if { [info exists password] } { + set status [$pdf _insertpassword $password] + } else { + if { [$pdf authentication] == "failed" } { + if { [catch {package present Tk}] } { + set askMethod [cli_passwordhelper] + } else { + set askMethod [tk_passwordhelper] + } + try { + set pswd [uplevel #0 $askMethod $filename] + } on error e { + $pdf destroy + error $e + } + set status [$pdf _insertpassword $pswd] + } else { + set status true + } + } + if { ! $status } { + $pdf destroy + return -code error -errorcode "MUPDF WRONGPASSWORD" "wrong password" + } + return $pdf +} + + # create a new empty PDF (0 pages) + # return a pdfObj to be used in subsequent operations (addpage ....) + # NOTE: + # if filename is locked by another process, this command raise an error like the follwing: + # "error copying "..../Tpt_NoPage.pdf" to "..filename..": permission denied + # +proc mupdf::new {filename} { + if { [mupdf::isopen $filename] } { + error "\"$filename\" is currently used by this process" + } + # may fail if it's locked by anoter process + variable _BaseDir + file copy -force ${_BaseDir}/Tpt_NoPage.pdf $filename + + return [mupdf::open $filename] +} + + + ## list all opened documents (as object-commnds) +proc mupdf::documents {} { + mupdf::Doc names +} + + ## list all opened documents (as normalized fullnames) + ## NOTE: "opened" means "opened by mupdf in this process" +proc mupdf::documentnames {} { + set L {} + foreach docObj [documents] { + lappend L [$docObj fullname] + } + return $L +} + + ## check if a given filename is a currently opened document + ## NOTE: "opened" means "opened by mupdf in this process"" +proc mupdf::isopen {filename} { + # NOTE: filenames returned by [documentnames] are normalized with the same + # identical logic; + # therefore it's enough to check if the "normalized names" are identical. + expr {[file normalize $filename] in [documentnames]} +} + + ## just for 1.x compatibility +proc mupdf::isobject {obj} { + info object is object $obj +} + + + + ## -- utilities for password ----------------------------------------------- + + ## === Internal procs. ======================================================= + ## WARNING: these are internal and unsupported procs. + ## Do not use them in your apps! + ## =========================================================================== + +namespace eval mupdf { + variable _PasswordHelper + variable _SerialNo + + set _PasswordHelper(cli,default) mupdf::_cli_askpassword + set _PasswordHelper(tk,default) mupdf::_tk_askpassword + set _PasswordHelper(cli) $_PasswordHelper(cli,default) + set _PasswordHelper(tk) $_PasswordHelper(tk,default) + + set _SerialNo 0 +} + + +proc mupdf::_newSerialNo {} { + variable _SerialNo + incr _SerialNo +} + +proc mupdf::cli_passwordhelper {args} { + _passwordhelper cli {*}$args +} +proc mupdf::tk_passwordhelper {args} { + _passwordhelper tk {*}$args +} + + # get/set +proc mupdf::_passwordhelper {mode args} { + # mode is cli or tk + variable _PasswordHelper + + switch -- [llength $args] { + 0 { return $_PasswordHelper($mode) } + 1 { + set cb [lindex $args 0] + if { $cb == "" } { + set _PasswordHelper($mode) $_PasswordHelper($mode,default) + } else { + set _PasswordHelper($mode) $cb + } + } + default { + error "wrong # args: should be \"mupdf::${mode}_passwordhelper ?command?\"" + } + } +} + + # very very simple +proc mupdf::_cli_askpassword {filename} { + puts -nonewline stdout "Enter password for \"[file tail $filename]\":" ; flush stdout + gets stdin +} + + # ask with timeout +proc mupdf::_cli_askpassword_timeout {timeout filename} { + set passGVarName "::mupdf::__TIMEOUT_[_newSerialNo]" + puts stdout "Enter pass for $filename ($timeout seconds):" ; flush stdout + # set timeout and fileevent on stdin ; + # both the timeout and fileevent callback will set the ::PASS global variable + set afterID [after [expr {1000*$timeout}] [list set $passGVarName "none"] ] + set oldCmd [fileevent stdin readable] + fileevent stdin readable [list apply { {f gvarname} { + upvar #0 $gvarname var + set var [gets $f] + }} stdin $passGVarName] + vwait $passGVarName + # -- reset timeout and fileevent + after cancel $afterID + fileevent stdin readable $oldCmd + + # get the result from the global variable, and unset it ! + set x [set $passGVarName] + unset $passGVarName + return $x + } + + +proc mupdf::_tk_askpassword {filename} { + # to do: center the window + set uniqueID [_newSerialNo] + set passGVarName "::mupdf::__PASS_${uniqueID}" + + set password "" + set topW [toplevel .ask_${uniqueID} -padx 10 -pady 10] + wm title $topW [file tail $filename] + wm attributes $topW -topmost true + label $topW.label -text "Enter password" + entry $topW.entry -textvariable $passGVarName + bind $topW.entry {destroy [winfo toplevel %W]} + pack $topW.label $topW.entry -side left + focus $topW.entry + + tkwait window $topW + after 0 [list unset $passGVarName] + return [set $passGVarName] +} + +proc mupdf::_tk_askpassword:timeout {filename} { + # to do: center the window + set uniqueID [_newSerialNo] + set passGVarName "::mupdf::__PASS_${uniqueID}" + + set password "" + set topW [toplevel .ask_${uniqueID} -padx 10 -pady 10] + wm title $topW [file tail $filename] + wm attributes $topW -topmost true + label $topW.label -text "Enter password" + entry $topW.entry -textvariable $passGVarName + bind $topW.entry {destroy [winfo toplevel %W]} + pack $topW.label $topW.entry -side left + focus $topW.entry + + set afterID [after [expr {1000*$timeout}] [list destroy $topW] ] + + tkwait window $topW + after 0 [list unset $passGVarName] + return [set $passGVarName] +} diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/class_Page.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/class_Page.tcl new file mode 100644 index 00000000..bae34789 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/class_Page.tcl @@ -0,0 +1,156 @@ +# class_Page.tcl +# +# class mupdf::Page extends class mupdf::Page_C (implemented in C) +# plus +# mudf::imagepattern command. + +# - Constructor +# The direct constructor is rarely used. +# Usually a new Page is created starting from a Doc object +# set pageObj [$docObj getpage _n_] +# Note that if page _n_ is already opened, the previous method returns the same +# pageObj +# +# - Destructor +# $pageObj destroy +# $pageObj close ;# alias for "$pageObj destroy" +# +# - Methods +# $pageObj pagenumber (* inherithed from Page_C *) +# $pageObj size (* inherithed from Page_C *) +# $pageObj savePNG _filename_ .... (* inherithed from Page_C *) +# $pageObj saveImage _tkImage_ .... (* inherithed from Page_C *) +# $pageObj blocks (* inherithed from Page_C *) +# $pageObj lines (* inherithed from Page_C *) +# $pageObj text (* inherithed from Page_C *) +# +# $pageObj images list ... (* inherithed from Page_C *) +# $pageObj images extract ... (* inherithed from Page_C *) +# +# $pageObj addimage ... (* inherithed from Page_C *) +# +# $pageObj annots (* inherithed from Page_C *) +# $pageObj annot create _type_ ..... (* inherithed from Page_C *) +# $pageObj annot ?get? _annotID_ (* inherithed from Page_C *) +# $pageObj annot ?get? _annotID_ -option (* inherithed from Page_C *) +# $pageObj annot ?set? _annotID_ -option value ...(* inherithed from Page_C *) +# $pageObj annot flatten _annotID_ ... (* inherithed from Page_C *) +# $pageObj annot delete _annotID_ ... (* inherithed from Page_C *) + +# Command for setting the filename pattern of the extracted images +# ( see above $pageObj images extract ... ) +# +# mupdf::imagepattern +# mupdf::imagepattern _newPattern_ + + + +oo::class create mupdf::Page { + superclass mupdf::Page_C + # has-component publisher .. see constructor + + variable -append DocRef + + constructor {docRef pageNum} { + set DocRef $docRef + + # create a publisher component and delegate some methods + publisher create [self]::publisher + oo::objdefine [self] forward events [self]::publisher events + oo::objdefine [self] forward register [self]::publisher register + oo::objdefine [self] forward unregister [self]::publisher unregister + + # when DocRef is destroyed, then destroy this page + $DocRef register !destroyed [self] [list [self] destroy] + + next $DocRef $pageNum + } + + destructor { + $DocRef unregister * [self] + if { [info object isa object [self]::publisher] } { + [self]::publisher destroy + } + next + } + + method close {} { + my destroy + } + + method docref {} { + return $DocRef + } +} + + # add common methods to mupdf::Page +oo::objdefine mupdf::Page { mixin mupdf::COMMON_TYPEMETHODS } + + + + ## + ## mupdf::imagepattern + ## +namespace eval mupdf { + + variable _IMG_PATTERN_SYMBOLS "pPiI" ;# CONSTANT + variable _IMG_PATTERN "" + variable _IMG_POSITIONAL_PATTERN "" + + proc __positional_pattern { format symbols } { + set rexpr "%(\[0-9\]*)(\[$symbols\])" ;# if symbols is "ABC" --> %([0-9]*)([ABC]) + set format [regsub -all $rexpr $format {%\20\1d}] + + set symPos 1 + foreach sym [split $symbols ""] { + # replace "%S" with "%i$"" ;# S is the symbol, i is its position + set format [regsub -all "%${sym}" $format "%${symPos}\$"] + incr symPos + } + return $format + } + + proc __used_symbols { pattern symbols } { + set usedSymbols "" + set rexpr "%\[0-9\]*(\[$symbols\])" ;# if symbols is "ABC" --> %[0-9]*([ABC]) + foreach {match sym} [regexp -all -inline $rexpr $pattern] { + if { [string first $sym $usedSymbols] == -1 } { + append usedSymbols $sym + } + } + return $usedSymbols + } + + proc _used_symbols {pattern} { + variable _IMG_PATTERN_SYMBOLS + __used_symbols $pattern ${_IMG_PATTERN_SYMBOLS} + } + + proc _positional_pattern {pattern} { + variable _IMG_PATTERN_SYMBOLS + __positional_pattern $pattern ${_IMG_PATTERN_SYMBOLS} + } + + proc imagepattern {args} { + variable _IMG_PATTERN + switch -- [llength $args] { + 0 { return ${_IMG_PATTERN} } + 1 { + variable _IMG_POSITIONAL_PATTERN + variable _IMG_USED_SYMBOLS + + set pattern [lindex $args 0] + set _IMG_PATTERN $pattern + set _IMG_USED_SYMBOLS [_used_symbols ${_IMG_PATTERN}] + set _IMG_POSITIONAL_PATTERN [_positional_pattern ${_IMG_PATTERN}] + } + default { + set myName [lindex [info level 0] 0] + error "wrong # args: must be: $myName ?pattern?" + } + } + + } + + imagepattern "IM-%4p" +} diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/class_TextSearch.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/class_TextSearch.tcl new file mode 100644 index 00000000..223fda69 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/class_TextSearch.tcl @@ -0,0 +1,188 @@ +# class_TextSearch.tcl +# +# class mupdf::TextSearch extends class mupdf::TextSearch_C (implemented in C) +# + +# - Constructor +# The following commands create a new TextSearch object acting on a given mupdf::Doc +# mupdf::TextSearch new $doc +# mupdf::TextSearch create id $doc +# +# - Destructor +# $searchObj destroy +# +# TextSearch objects are automatically destroyed when the related mupdf::Doc +# is destroyed. +# +# - Methods +# $searchObj docref +# $searchObj currpage ?pageNumber? +# $searchObj find _searchStr_ ?-max _N_? ?-currpage true/false? + +# inherithed from TextSearch_C +# $searchObj _pagesearch .... (low-level method used by 'find' *hidden*) + + + +oo::class create mupdf::TextSearch { + superclass mupdf::TextSearch_C + # hide internal C methods + unexport _pagesearch + + # has-component publisher .. see constructor + variable -append DocRef + variable -append CurrPageNumber + variable -append FromTop + + constructor {docRef args} { + set DocRef $docRef + # BugFix: Tcl8.6.4 returns an error if $docRef is NOT an object, + # instead of returning 0 (false). + # For this reason, do both things: catch the error and check if false + try { + set isDoc [info object isa typeof $docRef mupdf::Doc] + } on error {} { + set isDoc false + } + if { ! $isDoc } { + error "\"$docRef\" must be an instance of mupdf::Doc" + } + + set CurrPageNumber 0 + set FromTop true + + # create a publisher component and delegate some methods + publisher create [self]::publisher + oo::objdefine [self] forward events [self]::publisher events + oo::objdefine [self] forward register [self]::publisher register + oo::objdefine [self] forward unregister [self]::publisher unregister + + $DocRef register !destroyed [self] [list [self] destroy] + + next {*}$args ;# initialize TextSearch_C + } + + destructor { + catch {$DocRef unregister * [self]} + + if { [info object isa object [self]::publisher] } { + [self]::publisher destroy + } + next + } + + method docref {} { + return $DocRef + } + + # get/set the current search page + method currpage {args} { + switch -- [llength $args] { + 0 { + return $CurrPageNumber + } + 1 { + set pageNum [lindex $args 0] + set lastPage [expr [$DocRef npages] -1] + if { $pageNum < 0 || $pageNum > $lastPage } { + error "page-number must be between 0 and $lastPage" + } + set CurrPageNumber $pageNum + set FromTop true + return $CurrPageNumber + } + default { + error wrong # args: should be "[self] currpage ?pageNumber?" + } + } + } + + method find {searchStr args} { + # default + set max_hits 10 + set currpageOnly false + + set usage "[self] find _searchStr_ ?-max _N_? ?-currpageonly true/false?" + + while { $args != {} } { + set args [lassign $args opt] + if { [llength $args] == 0 } { + error "wrong # args: missing value for the last options \"$opt\"" + } + set args [lassign $args value] + + switch -- $opt { + "-max" { + set max_hits $value + # this is an arbitrary limit + if { $max_hits > 100 } { + error "value for \"${opt}\" must be between 1 and 100" + } + } + "-currpageonly" { + set currpageOnly $value + if { ! [string is boolean $currpageOnly] } { + error "value for \"${opt}\" must be a boolean value" + } + } + default { + error "bad option \"$opt\": should be \"$usage\"" + } + } + } + + # the following method will also update CurrPageNumber and + # FromTop will be set to false (i.e. next search will continue from the current position + set L [my _Extended_find $DocRef $CurrPageNumber $searchStr $FromTop $max_hits $currpageOnly] + return $L + } + + + # Look for $searchStr from the current search-position on the current page + # ( unless $resumeFromTop is true). + # If $currpageonly is true, the search is limited to the current page + # ( you can change it with $searchObj currpage _N_ ) + # else the search may continue on the next pages until $max_hits are found + # (or no more pages exist!). + # Side-effect: CurrentPageNumber may be changed, FromTop becomes false + + # MUMBLING.. : this method may open a lot of pages. + # Since you cannot simply do a "$doc closeallpages" sinces there may be + # somepages in use before, evaluate the convenience to check if a page was + # opened ($doc isopenedpage $n) before calling ($doc getpage $n) ; + # you could then close these 'new' pages (but please, don't close the + # last scanned page...it could be useful for more search ...) + # .. Think it over ... + method _Extended_find {doc pageNumber searchStr resumeFromTop max_hits currpageOnly} { + if { $searchStr == {} } { + error "undefined search string" + } + set L {} + set nPages [$DocRef npages] + while { true } { + # the following may fail if pageNumber is invalid .. OK + set pageHandle [$doc getpage $pageNumber] + set rectList [my _pagesearch $pageHandle $searchStr $max_hits $resumeFromTop] + foreach rect $rectList { + lappend L [list $pageNumber $rect] + } + incr max_hits [expr {-[llength $rectList]}] + + if { $currpageOnly } break + + if { $max_hits == 0 } break + + if { $pageNumber+1 == $nPages } { break } + + incr pageNumber + set resumeFromTop true + } + set CurrPageNumber $pageNumber + set FromTop false + return $L + } + +} + + # add common methods to mupdf::TextSearch +oo::objdefine mupdf::TextSearch { mixin mupdf::COMMON_TYPEMETHODS } diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/mupdf.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/mupdf.tcl new file mode 100644 index 00000000..9ac3402d --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/mupdf.tcl @@ -0,0 +1,104 @@ +# mupdf.tcl +# +# Startup utilities for the Tcl->MuPDF integration +# Load sub-modules for all the required Classes +# + + +namespace eval mupdf { + variable _BaseDir + set _BaseDir [file dirname [file normalize [info script]]] + + set ::auto_path [linsert $::auto_path 0 $_BaseDir/lib] +} + +proc mupdf::_findDLL {dir pkgName} { + set thisDir [file normalize ${dir}] + + set os $::tcl_platform(platform) + switch -- $os { + windows { set os win } + unix { + switch -- $::tcl_platform(os) { + Darwin { set os darwin } + Linux { set os linux } + } + } + } + set majorVersion [lindex [split [package present Tcl] "."] 0] + switch -- $majorVersion { + 8 {set vtag "86"} + 9 {set vtag "90"} + default { error "tclMuPDF: Unsupported Tcl version" } + } + switch -- $pkgName { + MuPDF - + tkMuPDF { + set libName "tkMuPDF" + } + tclMuPDF { + set libName "tclMuPDF" + } + default { + error "Unregistered package name \"$pkgName\"" + } + } + + set tail_libFile ${libName}${vtag}[info sharedlibextension] + # try to guess the tcl-interpreter architecture (32/64 bit) + set arch $::tcl_platform(pointerSize) + switch -- $arch { + 4 { set arch x32 } + 8 { set arch x64 } + default { error "${pkgName}: Unsupported architecture: Unexpected pointer-size $arch!!! "} + } + set dir_libFile [file join $thisDir ${os}-${arch}] + if { ! [file isdirectory $dir_libFile ] } { + error "${pkgName}: Unsupported platform ${os}-${arch}" + } + + set full_libFile [file join $dir_libFile $tail_libFile] + return $full_libFile +} + + # + # basic module for publish/subscribe pattern + # +package require publisher 2.0 + # helper for defining callbacks +proc oocallback {args} { + linsert $args 0 [uplevel 1 [list self namespace]]::my +} + + +namespace eval mupdf { + variable _classes + variable _BaseDir + + proc classes {} { + variable _classes + return $_classes + } + + proc classinfo {obj} { + info object class $obj + } + + oo::class create COMMON_TYPEMETHODS { + # return the (sorted) list of current instances + method names {} { + lsort [info class instances [lindex [info level 0] 0]] + } + } + + # create some basic classes whose implementation will be mostly written in C + + foreach clazz {Doc Page TextSearch} { + lappend _classes [namespace current]::$clazz + ::oo::class create ${clazz}_C { + # Constructor and methods are written in C + } + uplevel #0 source [list [file join $_BaseDir class_${clazz}.tcl]] + } + unset clazz +} diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/pkgIndex.tcl b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/pkgIndex.tcl new file mode 100644 index 00000000..dee6f34f --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/pkgIndex.tcl @@ -0,0 +1,17 @@ +package ifneeded tkMuPDF 2.5.1 [list apply { {dir ver} { + source [file join $dir mupdf.tcl] + load [mupdf::_findDLL $dir "tkMuPDF"] Mupdf + package provide tkMuPDF $ver +}} $dir 2.5.1] ;# end of lambda apply + +package ifneeded tclMuPDF 2.5.1 [list apply { {dir ver} { + source [file join $dir mupdf.tcl] + load [mupdf::_findDLL $dir "tclMuPDF"] Mupdf + package provide tclMuPDF $ver +}} $dir 2.5.1] ;# end of lambda apply + +# --- Alias +package ifneeded MuPDF 2.5.1 [list apply { {dir ver} { + package require -exact tkMuPDF $ver + package provide MuPDF $ver +}} $dir 2.5.1] ;# end of lambda apply diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/tclMuPDF-license.terms b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/tclMuPDF-license.terms new file mode 100644 index 00000000..dd6920d7 --- /dev/null +++ b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/tclMuPDF-license.terms @@ -0,0 +1,18 @@ +== tclMuPDF - Tcl meets MuPDF == + +tclMuPDF - Copyright (c) 2020-2023 : +MuPDF - Copyright (c) 2006-2022 Artifex Software, Inc. + +tclMuPDF is distributed the following license: + +This library is free software; you can use, modify, and redistribute it +for any purpose, provided that existing copyright notices are retained +in all copies and that this notice is included verbatim in any +distributions. + +Note that MuPDF license is GNU Affero General Public License v3 + +*Both licenses apply, when you use tclMuPDF* + +This software is distributed WITHOUT ANY WARRANTY; without even the +implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. \ No newline at end of file diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/win-x64/tclMuPDF86.dll b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/win-x64/tclMuPDF86.dll new file mode 100644 index 00000000..3e3276b4 Binary files /dev/null and b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/win-x64/tclMuPDF86.dll differ diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/win-x64/tclMuPDF90.dll b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/win-x64/tclMuPDF90.dll new file mode 100644 index 00000000..e4bf89c0 Binary files /dev/null and b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/win-x64/tclMuPDF90.dll differ diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/win-x64/tkMuPDF86.dll b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/win-x64/tkMuPDF86.dll new file mode 100644 index 00000000..7f0c02e2 Binary files /dev/null and b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/win-x64/tkMuPDF86.dll differ diff --git a/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/win-x64/tkMuPDF90.dll b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/win-x64/tkMuPDF90.dll new file mode 100644 index 00000000..322ffbef Binary files /dev/null and b/src/vfs/punk9win_for_tkruntime.vfs/lib_tcl9/tclMuPDF-win64-2.5.1/win-x64/tkMuPDF90.dll differ