jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

flagfilter object cleanups, punk::args default val fixes & error table improvements, textblock::table fixes

master
Julian Noble 5 months ago
parent
7f1c6a3f5e
commit
61541835ca
10 changed files with 449 additions and 126 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 38
      src/modules/flagfilter-0.3.tm
  2. 66
      src/modules/natsort-0.1.1.6.tm
  3. 230
      src/modules/punk/args-999999.0a1.0.tm
  4. 1
      src/modules/punk/cap/handlers/templates-999999.0a1.0.tm
  5. 2
      src/modules/punk/lib-999999.0a1.0.tm
  6. 7
      src/modules/punk/mix/commandset/layout-999999.0a1.0.tm
  7. 89
      src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm
  8. 8
      src/modules/punk/mix/commandset/module-999999.0a1.0.tm
  9. 68
      src/modules/punk/overlay-0.1.tm
  10. 64
      src/modules/textblock-999999.0a1.0.tm

38
src/modules/flagfilter-0.3.tm
Unescape View File

@ -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]} {

66
src/modules/natsort-0.1.1.6.tm
Unescape View File

@ -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"
}

230
src/modules/punk/args-999999.0a1.0.tm
Unescape View File

@ -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,58 +660,119 @@ 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
}
@ -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 {}

1
src/modules/punk/cap/handlers/templates-999999.0a1.0.tm
Unescape View File

@ -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]

2
src/modules/punk/lib-999999.0a1.0.tm
Unescape View File

@ -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

7
src/modules/punk/mix/commandset/layout-999999.0a1.0.tm
Unescape View File

@ -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]

89
src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm
Unescape View File

@ -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]

8
src/modules/punk/mix/commandset/module-999999.0a1.0.tm
Unescape View File

@ -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]

68
src/modules/punk/overlay-0.1.tm
Unescape View File

@ -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 <base>::lib::*
#}]
namespace eval ${routine}::lib [string map [list <base> $base <routine> $routine] {
if {[::namespace exists <base>::lib]} {
::set current_paths [namespace path]
tcl::namespace::eval ${routine}::lib [tcl::string::map [list <base> $base <routine> $routine] {
if {[tcl::namespace::exists <base>::lib]} {
::set current_paths [tcl::namespace::path]
if {"<routine>" ni $current_paths} {
::lappend current_paths <routine>
}
::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 <cmdns> $cmdnamespace] {
::set nspaths [::namespace path]
tcl::namespace::eval ${cmdnamespace}::lib [tcl::string::map [list <cmdns> $cmdnamespace] {
::set nspaths [tcl::namespace::path]
if {"<cmdns>" ni $nspaths} {
::lappend nspaths <cmdns>
}
::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
}]

64
src/modules/textblock-999999.0a1.0.tm
Unescape View File

@ -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 {

Write Preview
Loading…
Cancel
Save