From 61541835caea937d2810d966d9c872947e7a296b Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Thu, 20 Jun 2024 05:44:19 +1000 Subject: [PATCH] flagfilter object cleanups, punk::args default val fixes & error table improvements, textblock::table fixes --- src/modules/flagfilter-0.3.tm | 38 ++- src/modules/natsort-0.1.1.6.tm | 66 +++-- src/modules/punk/args-999999.0a1.0.tm | 232 ++++++++++++++---- .../cap/handlers/templates-999999.0a1.0.tm | 1 + src/modules/punk/lib-999999.0a1.0.tm | 2 +- .../mix/commandset/layout-999999.0a1.0.tm | 7 + .../mix/commandset/loadedlib-999999.0a1.0.tm | 89 ++++++- .../mix/commandset/module-999999.0a1.0.tm | 8 + src/modules/punk/overlay-0.1.tm | 68 ++--- src/modules/textblock-999999.0a1.0.tm | 64 ++++- 10 files changed, 449 insertions(+), 126 deletions(-) diff --git a/src/modules/flagfilter-0.3.tm b/src/modules/flagfilter-0.3.tm index 007a66b..1d37e21 100644 --- a/src/modules/flagfilter-0.3.tm +++ b/src/modules/flagfilter-0.3.tm @@ -1051,19 +1051,20 @@ namespace eval flagfilter { set sequence 0 set argerrors [list] ;#despite being a list - we will break out at first entry and return for now. set parsestatus "ok" - set LAUNCHED [oolib::collection create col_processors_launched_$runid] - set MATCHED [oolib::collection create col_processors_matched_$runid] - oo::objdefine col_processors_matched_$runid { - method test {} { - return 1 - } - } + + #set LAUNCHED [oolib::collection create col_processors_launched_$runid] + #set MATCHED [oolib::collection create col_processors_matched_$runid] + #oo::objdefine col_processors_matched_$runid { + # method test {} { + # return 1 + # } + #} #set objp [$PROCESSORS object_from_record $p] ;#temp convenience foreach objp [$PROCESSORS items] { set objparent [$objp parent] - $LAUNCHED add $objp [$objp name] + #$LAUNCHED add $objp [$objp name] set p [$objp get_def] ;#individual record e.g {mycmd {match run singleopts {-x}}} or {tail_processor {}} lassign $p parentname pinfo @@ -1599,6 +1600,12 @@ namespace eval flagfilter { lappend o_longopts {*}[dict get $o_pinfo longopts] } } + destructor { + catch {$o_vmap destroy} + if {!$o_is_sub} { + $o_col_children destroy + } + } method name {} { return $o_name @@ -2552,6 +2559,21 @@ namespace eval flagfilter { } } } + + + # --------------------------------- + foreach obj [$PARENTS items] { + catch {$obj destroy} + } + $PARENTS destroy + #puts "PROCESSORS: $PROCESSORS" + foreach obj [$PROCESSORS items] { + catch {$obj destroy} + } + $PROCESSORS destroy + catch {$RETURNED_VMAP destroy} + # --------------------------------- + do_debug 1 $debugc "[string repeat = 40]" do_debug 1 $debugc "DEBUG-END $caller" if {[string length $raise_dispatch_error_instead_of_return]} { diff --git a/src/modules/natsort-0.1.1.6.tm b/src/modules/natsort-0.1.1.6.tm index 9509f55..ec52c47 100644 --- a/src/modules/natsort-0.1.1.6.tm +++ b/src/modules/natsort-0.1.1.6.tm @@ -860,6 +860,11 @@ namespace eval natsort { #puts stdout "natsort::sort args: $args" variable debug if {![llength $stringlist]} return + if {[llength $stringlist] == 1} { + if {"-inputformat" ni $args && "-outputformat" ni $args} { + return $stringlist + } + } #allow pass through of the check_flags flag -debugargs so it can be set by the caller set debugargs 0 @@ -874,7 +879,8 @@ namespace eval natsort { #-return flagged|defaults doesn't work Review. #flagfilter global processor/allocator not working 2023-08 - set args [check_flags \ + + set flagspecs [dict create\ -caller natsort::sort \ -return supplied|defaults \ -debugargs $debugargs \ @@ -894,29 +900,45 @@ namespace eval natsort { -debug 0 -db "" -stacktrace 0 -splits "\uFFFF" -showsplits 0] \ -required {all} \ -extras {none} \ - -commandprocessors {} \ - -values $args] + -commandprocessors {}\ + ] + + set opts [check_flags {*}$flagspecs -values $args] + + #we can only shortcircuit input list of single element at this point if there aren't non-default -inputformat or -outputformat transformations + if {[llength $stringlist] == 1} { + set is_basic 1 + foreach fname [list -inputformat -outputformat] { + if {[dict get $flagspecs -defaults $fname] ne [dict get $opts $fname]} { + set is_basic 0 + break + } + } + if {$is_basic} { + return $stringlist + } + } + + + set winlike [dict get $opts -winlike] + set topchars [dict get $opts -topchars] + set cols [dict get $opts -cols] + set debug [dict get $opts -debug] + set stacktrace [dict get $opts -stacktrace] + set showsplits [dict get $opts -showsplits] + set splits [dict get $opts -splits] + set sortmethod [dict get $opts -sortmethod] + set opt_collate [dict get $opts -collate] + set opt_inputformat [dict get $opts -inputformat] + set opt_inputformatapply [dict get $opts -inputformatapply] + set opt_inputformatoptions [dict get $opts -inputformatoptions] + set opt_outputformat [dict get $opts -outputformat] + set opt_outputformatoptions [dict get $opts -outputformatoptions] - #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" + #dict unset opts -showsplits + #dict unset opts -splits + puts stdout "natsort::sort processed_args: $opts" if {$debug == 1} { puts stdout "natsort::sort - try also -debug 2, -debug 3" } diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index 35c4693..810eb2f 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -488,6 +488,7 @@ tcl::namespace::eval punk::args { } tcl::dict::set valspec_defaults $k $v } + -optional - -allow_ansi - -validate_without_ansi - -strip_ansi - @@ -637,6 +638,7 @@ tcl::namespace::eval punk::args { ] tcl::dict::set argspec_cache $cache_key $result tcl::dict::set argspecs $spec_id $optionspecs + #puts "xxx:$result" return $result } @@ -658,64 +660,125 @@ tcl::namespace::eval punk::args { proc Get_caller {} { set cmdinfo [tcl::dict::get [tcl::info::frame -3] cmd] #puts "-->$cmdinfo" + #puts "-->[tcl::info::frame -3]" set caller [regexp -inline {\S+} $cmdinfo] if {$caller eq "namespace"} { - set caller "punk::args::get_dict called from namespace" + set cmdinfo "punk::args::get_dict called from namespace" } - return $caller + return $cmdinfo } proc arg_error {msg spec_dict {badarg ""}} { set errmsg $msg if {![catch {package require textblock}]} { - append errmsg \n - set title "Usage" - if {[dict exists $spec_dict proc_info -name]} { - set title "Usage: [dict get $spec_dict proc_info -name]" - } - set t [textblock::class::table new [a+ web-yellow]$title[a]] - $t add_column -headers {Arg} - $t add_column -headers {Type} - $t add_column -headers {Default} - - set c_default [a+ web-white Web-limegreen] - set c_badarg [a+ web-crimson] - - foreach arg [dict get $spec_dict opt_names] { - set arginfo [dict get $spec_dict arg_info $arg] - if {[dict exists $arginfo -default]} { - #set default $c_default[dict get $arginfo -default] - set default [dict get $arginfo -default] + if {[catch { + append errmsg \n + set procname [punk::lib::dict_getdef $spec_dict proc_info -name ""] + set prochelp [punk::lib::dict_getdef $spec_dict proc_info -help ""] + + set t [textblock::class::table new [a+ web-yellow]Usage[a]] + + set blank_header_col [list ""] + if {$procname ne ""} { + lappend blank_header_col "" + set procname_display [a+ web-white]$procname[a] } else { - set default "" + set procname_display "" } - $t add_row [list $arg [dict get $arginfo -type] $default] - if {$arg eq $badarg} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $c_badarg + if {$prochelp ne ""} { + lappend blank_header_col "" + set prochelp_display [a+ web-white]$prochelp[a] + } else { + set prochelp_display "" } - } - foreach arg [dict get $spec_dict val_names] { - set arginfo [dict get $spec_dict arg_info $arg] - if {[dict exists $arginfo -default]} { - set default [dict get $arginfo -default] + $t add_column -headers $blank_header_col + $t add_column -headers $blank_header_col + $t add_column -headers $blank_header_col + $t add_column -headers $blank_header_col + $t add_column -headers $blank_header_col + if {"$procname$prochelp" eq ""} { + $t configure_header 0 -values {Arg Type Default Multiple Help} + } elseif {$procname eq ""} { + $t configure_header 0 -colspans {1 4 0 0 0} -values [list Description: $prochelp_display] + $t configure_header 1 -values {Arg Type Default Multiple Help} + } elseif {$prochelp eq ""} { + $t configure_header 0 -colspans {1 4 0 0 0} -values [list PROC/METHOD: $procname_display] + $t configure_header 1 -values {Arg Type Default Multiple Help} } else { - set default "" + $t configure_header 0 -colspans {1 4 0 0 0} -values [list PROC/METHOD: $procname_display] + $t configure_header 1 -colspans {1 4 0 0 0} -values [list Description: $prochelp_display] + $t configure_header 2 -values {Arg Type Default Multiple Help} } - $t add_row [list $arg [dict get $arginfo -type] $default] - if {$arg eq $badarg} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $c_badarg + + set c_default [a+ web-white Web-limegreen] + set c_badarg [a+ web-crimson] + set greencheck [a+ web-limegreen]\u2713[a] + + foreach arg [dict get $spec_dict opt_names] { + set arginfo [dict get $spec_dict arg_info $arg] + if {[dict exists $arginfo -default]} { + #set default $c_default[dict get $arginfo -default] + set default [dict get $arginfo -default] + } else { + set default "" + } + set help [punk::lib::dict_getdef $arginfo -help ""] + if {[dict exists $arginfo -choices]} { + if {$help ne ""} {append help \n} + append help "Choices: [dict get $arginfo -choices]" + } + if {[punk::lib::dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck + } else { + set multiple "" + } + $t add_row [list $arg [dict get $arginfo -type] $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $c_badarg + } + } + foreach arg [dict get $spec_dict val_names] { + set arginfo [dict get $spec_dict arg_info $arg] + if {[dict exists $arginfo -default]} { + set default [dict get $arginfo -default] + } else { + set default "" + } + set help [punk::lib::dict_getdef $arginfo -help ""] + if {[dict exists $arginfo -choices]} { + if {$help ne ""} {append help \n} + append help "Choices: [dict get $arginfo -choices]" + } + if {[punk::lib::dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck + } else { + set multiple "" + } + $t add_row [list $arg [dict get $arginfo -type] $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $c_badarg + } } - } - $t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ web-white] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow] - append errmsg [$t print] + $t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ web-white] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow] + $t configure -maxwidth 80 + append errmsg [$t print] + $t destroy + } 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" + + } } else { #todo - something boring } error $errmsg } - + #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 @@ -799,7 +862,10 @@ tcl::namespace::eval punk::args { set argspecs [Get_argspecs $optionspecs] tcl::dict::with argspecs {} ;#turn keys into vars #puts "-arg_info->$arg_info" - set flagsreceived [list] + 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 set opts $opt_defaults if {[set eopts [lsearch -exact $rawargs "--"]] >= 0} { @@ -812,13 +878,76 @@ tcl::namespace::eval punk::args { #we can't treat as first positional arg - as it comes before the eopt indicator -- arg_error "punk::args::get_dict bad options for [Get_caller]. Expected flag (leading -) at position $i got:$rawargs" $argspecs } - #TODO! - if {[tcl::dict::get $arg_info $a -type] ne "none"} { - if {[incr i] > $maxidx} { - arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $a which is not marked with -solo 1" $argspecs $a + + if {![catch {tcl::prefix match -message "options for %caller%. Unexpected option" $opt_names $a } fullopt]} { + if {[tcl::dict::get $arg_info $fullopt -type] ne "none"} { + #non-solo + set flagval [lindex $arglist $i+1] + if {[dict get $arg_info $fullopt -multiple]} { + #don't lappend to default - we need to replace if there is a default + #review - what if user sets first value that happens to match a default? + if {$fullopt ni $flagsreceived && [tcl::dict::exists $opt_defaults $fullopt] && ([tcl::dict::get $opt_defaults $fullopt] eq [tcl::dict::get $opts $fullopt])} { + #first occurrence of this flag, whilst stored value matches default + tcl::dict::set opts $fullopt $flagval + } else { + tcl::dict::lappend opts $fullopt $flagval + } + } else { + tcl::dict::set opts $fullopt $flagval + } + #incr i to skip flagval + 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 $fullopt + } + } else { + #type none (solo-flag) + if {[tcl::dict::get $arg_info $fullopt -multiple]} { + if {[tcl::dict::get $opts $fullopt] == 0} { + #review - what if default at time opt was specified is not zero? we will end up with more items in the list than the number of times the flag was specified + tcl::dict::set opts $fullopt 1 + } else { + tcl::dict::lappend opts $fullopt 1 + } + } else { + tcl::dict::set opts $fullopt 1 + } + } + lappend flagsreceived $fullopt ;#dups ok + } else { + if {$opt_any} { + set newval [lindex $arglist $i+1] + #opt was unspecified but is allowed due to *opt -any 1 - 'adhoc/passthrough' option + tcl::dict::set arg_info $a $optspec_defaults ;#use default settings for unspecified opt + tcl::dict::set arg_checks $a $opt_checks_defaults + if {[tcl::dict::get $arg_info $a -type] ne "none"} { + if {[tcl::dict::get $arg_info $a -multiple]} { + tcl::dict::lappend opts $a $newval + } else { + tcl::dict::set opts $a $newval + } + lappend flagsreceived $a ;#adhoc flag as supplied + 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 $a + } + } 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 $arg_info $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 + } + } + } else { + #delay Get_caller so only called in the unhappy path + set errmsg [tcl::string::map [list %caller% [Get_caller]] $fullopt] + arg_error $errmsg $argspecs $fullopt } } - lappend flagsreceived $a ;#dups ok + } } else { if {[lsearch $rawargs -*] >= 0} { @@ -841,7 +970,14 @@ tcl::namespace::eval punk::args { #non-solo set flagval [lindex $rawargs $i+1] if {[dict get $arg_info $fullopt -multiple]} { - tcl::dict::lappend opts $fullopt $flagval + #don't lappend to default - we need to replace if there is a default + #review - what if user sets first value that happens to match a default? + if {$fullopt ni $flagsreceived && [tcl::dict::exists $opt_defaults $fullopt] && ([tcl::dict::get $opt_defaults $fullopt] eq [tcl::dict::get $opts $fullopt])} { + #first occurrence of this flag, whilst stored value matches default + tcl::dict::set opts $fullopt $flagval + } else { + tcl::dict::lappend opts $fullopt $flagval + } } else { tcl::dict::set opts $fullopt $flagval } @@ -918,7 +1054,12 @@ tcl::namespace::eval punk::args { } if {$valname ne ""} { if {[tcl::dict::get $arg_info $valname -multiple]} { - tcl::dict::lappend values_dict $valname $val + if {[tcl::dict::exists $val_defaults $valname] && ([tcl::dict::get $val_defaults $valname] eq [tcl::dict::get $values_dict $valname])} { + #current stored val equals defined default - don't include default in the list we build up + tcl::dict::set values_dict $valname $val + } else { + tcl::dict::lappend values_dict $valname $val + } set in_multiple $valname } else { tcl::dict::set values_dict $valname $val @@ -1045,6 +1186,7 @@ tcl::namespace::eval punk::args { #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 if {$is_default == 0} { switch -- $type { any {} diff --git a/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm b/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm index 39eb5c2..4cc3f00 100644 --- a/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm +++ b/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm @@ -658,6 +658,7 @@ namespace eval punk::cap::handlers::templates { } $args] set opts [dict get $argd opts] set globsearches [dict get $argd values globsearches]; #note that in this case our globsearch won't reduce the machine's effort in scannning the filesystem - as we need to search on the renamed results + #puts stderr "=-=============>globsearches:$globsearches" # -- --- --- --- --- --- --- --- --- set opt_startdir [dict get $opts -startdir] set opt_templatefolder_subdir [dict get $opts -templatefolder_subdir] diff --git a/src/modules/punk/lib-999999.0a1.0.tm b/src/modules/punk/lib-999999.0a1.0.tm index 6b64ccf..2959d27 100644 --- a/src/modules/punk/lib-999999.0a1.0.tm +++ b/src/modules/punk/lib-999999.0a1.0.tm @@ -1821,7 +1821,7 @@ namespace eval punk::lib { #todo - way to generate 'internal' docs separately? #*** !doctools #[section Internal] -namespace eval punk::lib::system { +tcl::namespace::eval punk::lib::system { #*** !doctools #[subsection {Namespace punk::lib::system}] #[para] Internal functions that are not part of the API diff --git a/src/modules/punk/mix/commandset/layout-999999.0a1.0.tm b/src/modules/punk/mix/commandset/layout-999999.0a1.0.tm index 2acbf55..ba2663b 100644 --- a/src/modules/punk/mix/commandset/layout-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/layout-999999.0a1.0.tm @@ -82,6 +82,13 @@ namespace eval punk::mix::commandset::layout { } proc _default {args} { + punk::args::get_dict [subst { + *proc -name ::punk::mix::commandset::layout::collection::_default + -startdir -type string + -not -type string -multiple 1 + globsearches -default * -multiple 1 + }] $args + set tdict_low_to_high [as_dict {*}$args] #convert to screen order - with higher priority at the top set tdict [dict create] diff --git a/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm b/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm index 3788dc1..7bdce9a 100644 --- a/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm @@ -26,33 +26,102 @@ package require punk::lib namespace eval punk::mix::commandset::loadedlib { namespace export * #search automatically wrapped in * * - can contain inner * ? globs - proc search {searchstring} { + proc search {args} { + set argspecs { + *proc -name "punk::mix::commandset::loadedlib search" -help "search all Tcl libraries available to your local interpreter" + -return -type string -default table -choices {table tableobject list lines} + -present -type integer -default 2 -choices {0 1 2} -choicelabels {absent present both} -help "(unimplemented) Display only those that are 0:absent 1:present 2:both" + -highlight -type boolean -default 1 -help "Highlight which version is present with ansi underline and colour" + -refresh -default 0 -type boolean -help "Re-scan the tm and library folders" + searchstrings -default * -multiple 1 -help "Names to search for, may contain glob chars (* ?) e.g *lib* + If no glob chars are explicitly specified, the searchstring will be wrapped with star globs. + eg name -> *name* + " + } + set argd [punk::args::get_dict $argspecs $args] + set searchstrings [dict get $argd values searchstrings] + set opts [dict get $argd opts] + set opt_return [dict get $opts -return] + set opt_highlight [dict get $opts -highlight] + catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything if {[catch {package require natsort}]} { set has_natsort 0 } else { set has_natsort 1 } - if {[regexp {[?*]} $searchstring]} { - #caller has specified specific glob pattern - use it - #todo - respect supplied case only if uppers present? require another flag? - set matches [lsearch -all -inline -nocase [package names] $searchstring] - } else { - #make it easy to search for anything - set matches [lsearch -all -inline -nocase [package names] "*$searchstring*"] + set packages [package names] + set matches [list] + foreach search $searchstrings { + if {[regexp {[?*]} $search]} { + #caller has specified specific glob pattern - use it + #todo - respect supplied case only if uppers present? require another flag? + lappend matches {*}[lsearch -all -inline -nocase $packages $search] + } elseif {[string match =* $search]} { + lappend matches {*}[lsearch -all -inline -exact $packages [string range $search 1 end]] + } else { + #make it easy to search for anything + lappend matches {*}[lsearch -all -inline -nocase $packages "*$search*"] + } } - + set matches [lsort -unique $matches][unset matches] set matchinfo [list] + set highlight_ansi [a+ web-limegreen underline] + set RST [a] foreach m $matches { set versions [package versions $m] + if {![llength $versions]} { + #e.g builtins such as zlib - shows no versions - but will show version when package present/provide used + set versions [package provide $m] + #if {![catch {package present $m} v]} { + # set versions $v + #} + } if {$has_natsort} { set versions [natsort::sort $versions] } else { set versions [lsort $versions] } + if {$opt_highlight} { + set v [package provide $m] + if {$v ne ""} { + set posn [lsearch $versions $v] + if {$posn >= 0} { + #FIXME! (probably in textblock::pad ?) + #TODO - determine why underline is extended to padding even with double reset. (space or other char required to prevent) + set highlighted "$highlight_ansi$v$RST $RST" + set versions [lreplace $versions $posn $posn $highlighted] + } else { + #shouldn't be possible? + puts stderr "failed to find version '$v' in versions:$versions for package $m" + } + } + } lappend matchinfo [list $m $versions] } - return [join [lsort $matchinfo] \n] + switch -- $opt_return { + list { + return $matchinfo + } + lines { + return [join $matchinfo \n] + } + table - tableobject { + set t [textblock::class::table new] + $t add_column -headers "Package" + $t add_column -headers "Version" + $t configure -show_hseps 0 + foreach m $matchinfo { + $t add_row [list [lindex $m 0] [join [lindex $m 1] " "]] + } + if {$opt_return eq "tableobject"} { + return $t + } + set result [$t print] + $t destroy + return $result + } + } } proc loaded.search {searchstring} { set search_result [search $searchstring] diff --git a/src/modules/punk/mix/commandset/module-999999.0a1.0.tm b/src/modules/punk/mix/commandset/module-999999.0a1.0.tm index 9a5cbcc..7f3c7aa 100644 --- a/src/modules/punk/mix/commandset/module-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/module-999999.0a1.0.tm @@ -122,6 +122,14 @@ namespace eval punk::mix::commandset::module { } #return all module templates with repeated ones suffixed with .2 .3 etc proc templates_dict {args} { + set argspec { + *proc -name templates_dict -help "Templates from module and project paths" + -startdir -default "" -help "Project folder used in addition to module paths" + -not -default "" -multiple 1 + *values + globsearches -default * -multiple 1 + } + set argd [punk::args::get_dict $argspec $args] package require punk::cap if {[punk::cap::capability_has_handler punk.templates]} { set template_folder_dict [punk::cap::call_handler punk.templates get_itemdict_moduletemplates {*}$args] diff --git a/src/modules/punk/overlay-0.1.tm b/src/modules/punk/overlay-0.1.tm index b11e8c5..5534dad 100644 --- a/src/modules/punk/overlay-0.1.tm +++ b/src/modules/punk/overlay-0.1.tm @@ -2,37 +2,37 @@ package require punk::mix::util -namespace eval ::punk::overlay { +tcl::namespace::eval ::punk::overlay { #based *loosely* on: wiki.tcl-lang.org/page/ensemble+extend # extend an ensemble-like routine with the routines in some namespace # # e.g custom_from_base ::punk::mix::cli ::punk::mix::base # proc custom_from_base {routine base} { - if {![string match ::* $routine]} { - set resolved [uplevel 1 [list ::namespace which $routine]] + if {![tcl::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 [namespace qualifiers $routine] + set routinens [tcl::namespace::qualifiers $routine] if {$routinens eq {::}} { set routinens {} } - set routinetail [namespace tail $routine] + set routinetail [tcl::namespace::tail $routine] - if {![string match ::* $base]} { + if {![tcl::string::match ::* $base]} { set base [uplevel 1 [ - list [namespace which namespace] current]]::$base + list [tcl::namespace::which namespace] current]]::$base } - if {![namespace exists $base]} { + if {![tcl::namespace::exists $base]} { error [list {no such namespace} $base] } - set base [namespace eval $base [ - list [namespace which namespace] current]] + set base [tcl::namespace::eval $base [ + list [tcl::namespace::which namespace] current]] #while 1 { @@ -40,8 +40,8 @@ namespace eval ::punk::overlay { # if {[namespace which $renamed] eq {}} break #} - namespace eval $routine [ - ::list namespace ensemble configure $routine -unknown [ + tcl::namespace::eval $routine [ + ::list tcl::namespace::ensemble configure $routine -unknown [ ::list ::apply {{base ensemble subcommand args} { ::list ${base}::_redirected $ensemble $subcommand }} $base @@ -57,25 +57,25 @@ namespace eval ::punk::overlay { # ::namespace import ::lib::* #}] - namespace eval ${routine}::lib [string map [list $base $routine] { - if {[::namespace exists ::lib]} { - ::set current_paths [namespace path] + tcl::namespace::eval ${routine}::lib [tcl::string::map [list $base $routine] { + if {[tcl::namespace::exists ::lib]} { + ::set current_paths [tcl::namespace::path] if {"" ni $current_paths} { ::lappend current_paths } - ::namespace path $current_paths + tcl::namespace::path $current_paths } }] - namespace eval $routine { + tcl::namespace::eval $routine { ::set exportlist [::list] - ::foreach cmd [::info commands [::namespace current]::*] { - ::set c [::namespace tail $cmd] - if {![::string match _* $c]} { + ::foreach cmd [tcl::info::commands [tcl::namespace::current]::*] { + ::set c [tcl::namespace::tail $cmd] + if {![tcl::string::match _* $c]} { ::lappend exportlist $c } } - ::namespace export {*}$exportlist + tcl::namespace::export {*}$exportlist } return $routine @@ -96,20 +96,20 @@ namespace eval ::punk::overlay { } #namespace may or may not be a package # allow with or without leading :: - if {[string range $cmdnamespace 0 1] eq "::"} { - set cmdpackage [string range $cmdnamespace 2 end] + if {[tcl::string::range $cmdnamespace 0 1] eq "::"} { + set cmdpackage [tcl::string::range $cmdnamespace 2 end] } else { set cmdpackage $cmdnamespace set cmdnamespace ::$cmdnamespace } - if {![namespace exists $cmdnamespace]} { + if {![tcl::namespace::exists $cmdnamespace]} { #only do package require if the namespace not already present catch {package require $cmdpackage} pkg_load_info #recheck - if {![namespace exists $cmdnamespace]} { + if {![tcl::namespace::exists $cmdnamespace]} { set prov [package provide $cmdpackage] - if {[string length $prov]} { + if {[tcl::string::length $prov]} { set provinfo "(package $cmdpackage is present with version $prov)" } else { set provinfo "(package $cmdpackage not present)" @@ -121,21 +121,21 @@ namespace eval ::punk::overlay { punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${cmdnamespace}::util #let child namespace 'lib' resolve parent namespace and thus util::xxx - namespace eval ${cmdnamespace}::lib [string map [list $cmdnamespace] { - ::set nspaths [::namespace path] + tcl::namespace::eval ${cmdnamespace}::lib [tcl::string::map [list $cmdnamespace] { + ::set nspaths [tcl::namespace::path] if {"" ni $nspaths} { ::lappend nspaths } - ::namespace path $nspaths + tcl::namespace::path $nspaths }] set imported_commands [list] - set nscaller [uplevel 1 [list namespace current]] + set nscaller [uplevel 1 [list tcl::namespace::current]] if {[catch { #review - noclobber? - namespace eval ${nscaller}::temp_import [list ::namespace import ${cmdnamespace}::*] - foreach cmd [info commands ${nscaller}::temp_import::*] { - set cmdtail [namespace tail $cmd] + tcl::namespace::eval ${nscaller}::temp_import [list tcl::namespace::import ${cmdnamespace}::*] + foreach cmd [tcl::info::commands ${nscaller}::temp_import::*] { + set cmdtail [tcl::namespace::tail $cmd] if {$cmdtail eq "_default"} { set import_as ${nscaller}::${prefix} } else { @@ -153,7 +153,7 @@ namespace eval ::punk::overlay { } -package provide punk::overlay [namespace eval punk::overlay { +package provide punk::overlay [tcl::namespace::eval punk::overlay { variable version set version 0.1 }] diff --git a/src/modules/textblock-999999.0a1.0.tm b/src/modules/textblock-999999.0a1.0.tm index 3ffa2ba..ea8795d 100644 --- a/src/modules/textblock-999999.0a1.0.tm +++ b/src/modules/textblock-999999.0a1.0.tm @@ -2926,8 +2926,27 @@ tcl::namespace::eval textblock { set col [lindex $memcols 0] set space_to_alloc [expr {$hwidth - [tcl::dict::get $colwidths $col]}] if {$space_to_alloc > 0} { - tcl::dict::set colwidths $col $hwidth - tcl::dict::set colspace_added $col $space_to_alloc + 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 @@ -2941,7 +2960,7 @@ tcl::namespace::eval textblock { } #review - we want to reduce overallocation to earlier or later columns - hence the use of colspace_added switch -- $allocmethod { - 0 { + least { #add to least-expanded each time #safer than method 1 - pretty balanced if {$space_to_alloc > 0} { @@ -2960,7 +2979,39 @@ tcl::namespace::eval textblock { } } } - 1 { + 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} { @@ -3137,12 +3188,13 @@ tcl::namespace::eval textblock { } span { #widest of smallest spans first method - set calcresult [my columncalc_spans 0] + #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 1] + set calcresult [my columncalc_spans all] set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] } default {