#note - we can't use something like md5 to ID proc body text because we don't want to require additional packages.
#We could store the full text of the body to compare - but we need to identify magic strings from cooperating packages such as packageTrace
#A magic comment was chosen as the identifying method.
#The string IMPLEMENTOR_*! is searched for where the text between _ and ! is the name of the package that implemented the proc.
#return unspecified if the command is a proc with a body but no magic comment ID
#return unknown if the command doesn't have a proc body to analyze
#otherwise return the package name identified in the magic comment
proc get_IMPLEMENTOR {command} {
#assert - command has already been resolved to a namespace ie fully qualified
if {[llength [info procs $command]]} {
#look for *IMPLEMENTOR_*!
set prefix IMPLEMENTOR_
set suffix "!"
set body [uplevel 1 [list info body $command]]
if {[string match "*$prefix*$suffix*" $body]} {
set prefixposn [string first "$prefix" $body]
set pkgposn [expr {$prefixposn + [string length $prefix]}]
#set suffixposn [string first $suffix [string range $body $pkgposn $pkgposn+60]]
set suffixposn [string first $suffix $body $pkgposn]
return [string range $body $pkgposn $suffixposn-1]
} else {
return unspecified
}
} else {
if {[info commands tcl::info::cmdtype] ne ""} {
#tcl9 and maybe some tcl 8.7s ?
switch -- [tcl::info::cmdtype $command] {
native {
return builtin
}
default {
return undetermined
}
}
} else {
return undetermined
}
}
}
}
namespace eval commandstack::renamed_commands {}
namespace eval commandstack::temp {} ;#where we create proc initially before renaming into place
namespace eval commandstack {
namespace export {[a-z]*}
proc help {} {
return {
}
}
proc debug {{on_off {}}} {
variable debug
if {$on_off eq ""} {
return $debug
} else {
if {[string is boolean -strict $debug]} {
set debug [expr {$on_off && 1}]
return $debug
}
}
}
proc get_stack {{command ""}} {
variable all_stacks
if {$command eq ""} {
return $all_stacks
}
set command [uplevel 1 [list namespace which $command]]
if {[dict exists $all_stacks $command]} {
return [dict get $all_stacks $command]
} else {
return [list]
}
}
#get the implementation to which the renamer (renamer is usually calling namespace) originally renamed it, or the implementation it now points to.
#review - performance impact. Possible to use oo for faster dispatch whilst allowing stack re-orgs?
#e.g if renaming builtin 'package' - this command is generally called 'a lot'
proc get_next_command {command renamer tokenid} {
variable all_stacks
if {[dict exists $all_stacks $command]} {
set stack [dict get $all_stacks $command]
#stack is a list of dicts, 1st entry is token {<cmd> <renamer> <tokenid>}
set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]]
if {$posn > -1} {
set record [lindex $stack $posn]
return [dict get $record implementation]
} else {
error "(commandstack::get_next_command) ERROR: unable to determine next command for '$command' using token: $command $renamer $tokenid"
}
} else {
return $command
}
}
proc basecall {command args} {
variable all_stacks
set command [uplevel 1 [list namespace which $command]]
if {[dict exists $all_stacks $command]} {
set stack [dict get $all_stacks $command]
if {[llength $stack]} {
set rec1 [lindex $stack 0]
tailcall [dict get $rec1 implementation] {*}$args
} else {
tailcall $command {*}$args
}
} else {
tailcall $command {*}$args
}
}
#review.
#<renamer> defaults to calling namespace - but can be arbitrary string
proc rename_command {args} {
#todo: consider -forcebase 1 or similar to allow this rename to point to bottom of stack (original command) bypassing existing renames
# - need to consider that upon removing, that any remaining rename that was higher on the stack should not also be diverted to the base - but rather to the next lower in the stack
set command [uplevel 1 [list namespace which $command]]
if {$command eq ""} {
#review
puts stderr "commandstack::rename_command no rename performed for command '$command' by '$renamer'. command '$command' not found in calling context. Ensure command name is fully qualified or that command exists."
#add something to stack?
return [dict create implementation ""]
}
set mungedcommand [string map {:: _ns_} $command]
set mungedrenamer [string map {:: _ns_} $renamer]
variable all_stacks
variable known_renamers
variable renamer_command_tokens ;#monotonically increasing int per <mungedrenamer>::<mungedcommand> representing number of renames ever done.
if {$renamer eq ""} {
set renamer [uplevel 1 [list namespace current]]
}
if {$renamer ni $known_renamers} {
lappend known_renamers $renamer
dict set renamer_command_tokens [list $renamer $command] 0
}
#TODO - reduce emissions to stderr - flag for debug?
#e.g packageTrace and packageSuppress packages use this convention.
set nextinfo [uplevel 1 [list\
apply {{command renamer procbody} {
#todo - munge dash so we can make names in renamed_commands separable
# {- _dash_} ?
set mungedcommand [string map {:: _ns_} $command]
set mungedrenamer [string map {:: _ns_} $renamer]
set tokenid [lindex [dict incr renamer_command_tokens [list $renamer $command]] 1]
set next_target ::commandstack::renamed_commands::${mungedcommand}-original-$mungedrenamer-$tokenid ;#default is to assume we are the only one playing around with it, but we'll check for known associates too.
puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename."
puts stderr [::commandstack::show_stack $command]
} else {
puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding."
puts stdout "----------"
puts stdout "$current_code"
puts stdout "----------"
puts stdout "$new_code"
puts stdout "----------"
set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid
set do_rename 1
}
} else {
puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)"
puts stderr
set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid
set do_rename 1
}
} elseif {$next_implementor in $::commandstack::known_renamers} {
set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid
set do_rename 1
} elseif {$next_implementor in {builtin}} {
#native/builtin could still have been renamed
set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid
set do_rename 1
} elseif {$next_implementor in {unspecified undetermined}} {
#could be a standard tcl proc, or from application or package
set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid
set do_rename 1
} else {
puts stderr "(commandstack::rename_command) Warning - pkg:'$next_implementor' has renamed the '$command' command. Attempting to cooperate. (untested)"
set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid
set do_rename 1
}
} else {
#_originalcommand_<mungedcommand>
#assume builtin/original
set next_implementor original
#rename $command $next_target
set do_rename 1
}
#There are of course other ways in which $command may have been renamed - but we can't detect.
#todo - concept of 'pop' for renamer. Remove topmost entry specific to the renamer
#todo - removal by token to allow renamer to have multiple entries for one command but to remove one that is not the topmost
#todo - removal of all entries pertaining to a particular renamer
#todo - allow restore to bottom-most implementation (original) - regardless of what renamers have cooperated in the stack?
#remove by token, or by commandname if called from same context as original rename_command
#If only a commandname is supplied, and there were multiple renames from the same context (same -renamer) only the topmost is removed.
#A call to remove_rename with no token or renamer, and from a namespace context which didn't perform a rename will not remove anything.
#similarly a nonexistant token or renamer will not remove anything and will just return the current stack
proc remove_rename {token_or_command} {
if {[llength $token_or_command] == 3} {
#is token
lassign $token_or_command command renamer tokenid
} elseif {[llength $token_or_command] == 2} {
#command and renamer only supplied
lassign $token_or_command command renamer
set tokenid ""
} elseif {[llength $token_or_command] == 1} {
#is command name only
set command $token_or_command
set renamer [uplevel 1 [list namespace current]]
set tokenid ""
}
set command [uplevel 1 [list namespace which $command]]
variable all_stacks
variable known_renamers
if {$renamer ni $known_renamers} {
error "(commandstack::remove_rename) ERROR: renamer $renamer not in list of known_renamers '$known_renamers' for command '$command'. Ensure remove_rename called from same context as rename_command was, or explicitly supply exact token or {<command> <renamer>}"
}
if {[dict exists $all_stacks $command]} {
set stack [dict get $all_stacks $command]
if {$tokenid ne ""} {
#token_or_command is a token as returned within the rename_command result dictionary
#search first dict value
set doomed_posn [lsearch -index 1 $stack $token_or_command]
} else {
#search second dict value
set matches [lsearch -all -index 3 $stack $renamer]
set doomed_posn [lindex $matches end] ;#we don't have a full token - pop last entry for this renamer
}
if {$doomed_posn ne "" && $doomed_posn > -1} {
set doomed_record [lindex $stack $doomed_posn]
if {[llength $stack] == ($doomed_posn + 1)} {
#last on stack - put the implemenation from the doomed_record back as the actual command
uplevel #0 [list rename $command ""]
uplevel #0 [list rename [dict get $doomed_record implementation] $command]
#there is at least one more record on the stack - rewrite it to point where the doomed_record pointed
set rewrite_posn [expr {$doomed_posn + 1}]
set rewrite_record [lindex $stack $rewrite_posn]
if {[dict get $rewrite_record next_implementor] ne $renamer} {
puts stderr "(commandstack::remove_rename) WARNING: next record on the commandstack didn't record '$renamer' as the next_implementor - not deleting implementation [dict get $rewrite_record implementation]"
} else {
uplevel #0 [list rename [dict get $rewrite_record implementation] ""]
}
dict set rewrite_record next_implementor [dict get $doomed_record next_implementor]
#don't update next_getter - it always refers to self
dict set rewrite_record implementation [dict get $doomed_record implementation]
lset stack $rewrite_posn $rewrite_record
dict set all_stacks $command $stack
}
set stack [lreplace $stack $doomed_posn $doomed_posn]
dict set all_stacks $command $stack
}
return $stack
}
return [list]
}
proc show_stack {{commandname_glob *}} {
variable all_stacks
if {![regexp {[?*]} $commandname_glob]} {
#if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace
set commandname_glob [uplevel 1 [list namespace which $commandname_glob]]
}
if {[package provide punk::lib] ne "" && [package provide punk] ne ""} {
return "$overtext[string range $undertext $overlen end]"
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.
#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.
@ -282,7 +277,7 @@ namespace eval natsort {
set segments [list]
set segments [list]
while {[string length $name]} {
while {[string length $name]} {
if {[scan $name {%[0-9]%n} chunk len] == 2} {
if {[scan $name {%[0-9]%n} chunk len] == 2} {
lappend segments $chunk
lappend segments $chunk
set name [string range $name $len end]
set name [string range $name $len end]
}
}
if {[scan $name {%[^0-9]%n} chunk len] == 2} {
if {[scan $name {%[^0-9]%n} chunk len] == 2} {
@ -295,7 +290,7 @@ namespace eval natsort {
proc padleft {str count {ch " "}} {
proc padleft {str count {ch " "}} {
set val [string repeat $ch $count]
set val [string repeat $ch $count]
append val $str
append val $str
set diff [expr {max(0,$count - [string length $str])}]
set diff [expr {max(0,$count - [string length $str])}]
set collate [string trim [dict get $args -collate]]
set collate [string trim [dict get $args -collate]]
@ -319,8 +313,7 @@ namespace eval natsort {
set topdot [expr {"." in $topchars}]
set topdot [expr {"." in $topchars}]
set topunderscore [expr {"_" in $topchars}]
set topunderscore [expr {"_" in $topchars}]
sqlite3 db_sort_basic $db
sqlite3 db_sort_basic $db
set orderedlist [list]
set orderedlist [list]
db_sort_basic eval [string map [list %collate% $collate] {create table sqlitesort(index0 text COLLATE %collate%, name text COLLATE %collate%)}]
db_sort_basic eval [string map [list %collate% $collate] {create table sqlitesort(index0 text COLLATE %collate%, name text COLLATE %collate%)}]
@ -351,7 +344,7 @@ namespace eval natsort {
incr s
incr s
}
}
puts stdout ">>$index"
puts stdout ">>$index"
db_sort_basic eval {insert into sqlitesort values($index,$nm)}
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 }] {
db_sort_basic eval [string map [list %collate% $collate] {select name from sqlitesort order by index0 COLLATE %collate% ASC, name COLLATE %collate% ASC }] {
error "build_key assertion fail llength parts != 1 parts:$parts"
error "build_key assertion fail llength parts != 1 parts:$parts"
@ -640,7 +619,7 @@ namespace eval natsort {
##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"
##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.
#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 test_trim [string trim $sub]
set str $sub
set str $sub
set str [string tolower $str]
set str [string tolower $str]
set str [string map $index_map $str]
set str [string map $index_map $str]
if {[string length $test_trim] && [string is digit $test_trim]} {
if {[string length $test_trim] && [string is digit $test_trim]} {
@ -648,22 +627,21 @@ namespace eval natsort {
} else {
} else {
append partsorter "$str"
append partsorter "$str"
}
}
append partsorter
append partsorter
}
}
foreach sub $subsegments {
foreach sub $subsegments {
if {[string length $sub] && [string is digit $sub]} {
if {[string length $sub] && [string is digit $sub]} {
set basenum [trimzero [string trim $sub]]
set basenum [trimzero [string trim $sub]]
set subequivs $basenum
set subequivs $basenum
set lengthindex "[padleft [string length $subequivs] 4]d "
set lengthindex "[padleft [string length $subequivs] 4]d "
set idx "$lengthindex [padleft $basenum 10]" ;#todo - cycle through data and determine longest
set idx "$lengthindex [padleft $basenum 10]" ;#todo - cycle through data and determine longest
set tail [overtype::left [string repeat " " 10] $sub]
set tail [overtype::left [string repeat " " 10] $sub]
#set tail ""
#set tail ""
} else {
} else {
set idx ""
set idx ""
set lookahead [lindex $subsegments $i+1]
set lookahead [lindex $subsegments $i+1]
if {![string length $lookahead]} {
if {![string length $lookahead]} {
@ -680,12 +658,11 @@ namespace eval natsort {
append idx $zeronum
append idx $zeronum
set idx $subequivs
set idx $subequivs
#<removed tag_dashes test put above - review>
#<removed tag_dashes test put above - review>
set ch "-"
set ch "-"
if {$tag_dashes} {
if {$tag_dashes} {
#puts stdout "____TAG DASHES"
#puts stdout "____TAG DASHES"
#winlike
#winlike
set numleading [get_leading_char_count $seg $ch]
set numleading [get_leading_char_count $seg $ch]
@ -704,12 +681,9 @@ namespace eval natsort {
append textail "<30>"
append textail "<30>"
}
}
} else {
} else {
set texttail "<30>"
set texttail "<30>"
}
}
#set idx $partsorter
#set idx $partsorter
set tail ""
set tail ""
#set tail [string tolower $sub] ;#raw
#set tail [string tolower $sub] ;#raw
@ -721,12 +695,8 @@ namespace eval natsort {
incr i
incr i
}
}
if {$p eq ""} {
if {$p eq ""} {
# no subsegments..
# no subsegments..
set zeronum "[padleft 0 4]d0"
set zeronum "[padleft 0 4]d0"
#append grouping "\u000$zerotail"
#append grouping "\u000$zerotail"
append grouping ".$zeronum"
append grouping ".$zeronum"
@ -742,12 +712,10 @@ namespace eval natsort {
set grouping [string trimright $grouping $s]
set grouping [string trimright $grouping $s]
append grouping "[padleft [llength $parts] 4]"
append grouping "[padleft [llength $parts] 4]"
append segtail $grouping
append segtail $grouping
#append segtail " <[padleft [llength $parts] 4]>"
#append segtail " <[padleft [llength $parts] 4]>"
append segtail "\]"
append segtail "\]"
#if {[string length $seg] && [string is digit $seg]} {
#if {[string length $seg] && [string is digit $seg]} {
#we have split on this character $s so if the first part is empty string then $s was a leading character
#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 <S..>
# we need to bring a tag out front for this, or it will be dominated by the leading sections-remaing tag <S..>
# (since the empty string produces no tag of it's own - ?)
# (since the empty string produces no tag of it's own - ?)
if {[string length [lindex $parts 0]] == 0} {
if {[string length [lindex $parts 0]] == 0} {
set prefix ${joiner}
set prefix ${joiner}
} else {
} else {
set prefix ""
set prefix ""
}
}
@ -813,7 +778,7 @@ namespace eval natsort {
#----------------------------------------
#----------------------------------------
#line-processors - data always last argument - opts can be empty string
#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
#all processor should accept empty opts and ignore opts if they don't use them
proc _lineinput_as_tcl1 {opts line} {
proc _lineinput_as_tcl1 {opts line} {
set out ""
set out ""
foreach i $line {
foreach i $line {
@ -857,7 +822,7 @@ namespace eval natsort {
return [csv::split $line {*}$opts]
return [csv::split $line {*}$opts]
}
}
}
}
#opts same as tcllib csv::join
#opts same as tcllib csv::join
#?sepChar? ?delChar? ?delMode?
#?sepChar? ?delChar? ?delMode?
proc _lineoutput_as_csv {opts line} {
proc _lineoutput_as_csv {opts line} {
package require csv
package require csv
@ -902,7 +867,7 @@ namespace eval natsort {
return $stringlist
return $stringlist
}
}
}
}
#allow pass through of the check_flags flag -debugargs so it can be set by the caller
#allow pass through of the check_flags flag -debugargs so it can be set by the caller
set debugargs 0
set debugargs 0
if {[set posn [lsearch $args -debugargs]] >=0} {
if {[set posn [lsearch $args -debugargs]] >=0} {
@ -917,7 +882,7 @@ namespace eval natsort {
#-return flagged|defaults doesn't work Review.
#-return flagged|defaults doesn't work Review.
#flagfilter global processor/allocator not working 2023-08
#flagfilter global processor/allocator not working 2023-08
set opts [check_flags {*}$sort_flagspecs -debugargs $debugargs -values $args]
set opts [check_flags {*}$sort_flagspecs -debugargs $debugargs -values $args]
#we can only shortcircuit input list of single element at this point if there aren't non-default -inputformat or -outputformat transformations
#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} {
if {[llength $stringlist] == 1} {
@ -951,13 +916,13 @@ namespace eval natsort {
if {$debug} {
if {$debug} {
#dict unset opts -showsplits
#dict unset opts -showsplits
#dict unset opts -splits
#dict unset opts -splits
puts stdout "natsort::sort processed_args: $opts"
puts stdout "natsort::sort processed_args: $opts"
if {$debug == 1} {
if {$debug == 1} {
puts stdout "natsort::sort - try also -debug 2, -debug 3"
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
#set sortmethod "-dictionary" ;# sorts a2b before a001b - possibly other strangenesses that are hard to reason about
switch -- $sortmethod {
switch -- $sortmethod {
dictionary - ascii {
dictionary - ascii {
@ -999,23 +964,23 @@ namespace eval natsort {
#set commonsplits [list]
#set commonsplits [list]
set tagconfig [dict create]
set tagconfig [dict create]
dict set tagconfig last_part_text_tag "<19>"
dict set tagconfig last_part_text_tag "<19>"
if {$winlike} {
if {$winlike} {
set splitchars $winsplits
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.
#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
set wintop [list "(" ")" { } {.} {_}] ;#windows specific order
foreach t $topchars {
foreach t $topchars {
if {$t ni $wintop} {
if {$t ni $wintop} {
lappend wintop $t
lappend wintop $t
}
}
}
}
set topchars $wintop
set topchars $wintop
dict set tagconfig last_part_text_tag ""
dict set tagconfig last_part_text_tag ""
} else {
} else {
set splitchars $commonsplits
set splitchars $commonsplits
}
}
if {$splits ne "\uFFFF"} {
if {$splits ne "\uFFFF"} {
set splitchars $splits
set splitchars $splits
}
}
dict set tagconfig original_splitchars $splitchars
dict set tagconfig original_splitchars $splitchars
dict set tagconfig showsplits $showsplits
dict set tagconfig showsplits $showsplits
@ -1023,11 +988,11 @@ namespace eval natsort {
#create topdict
#create topdict
set i 0
set i 0
set topdict [dict create]
set topdict [dict create]
foreach c $topchars {
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)
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>"
dict set topdict $c "<0$i>"
}
}
set keylist [list]
set keylist [list]
switch -- $opt_inputformat {
switch -- $opt_inputformat {
tcl {
tcl {
@ -1037,12 +1002,12 @@ namespace eval natsort {
set lineinput_transform [list _lineinput_as_csv $opt_inputformatoptions]
set lineinput_transform [list _lineinput_as_csv $opt_inputformatoptions]
}
}
raw {
raw {
set lineinput_transform [list _lineinput_as_raw $opt_inputformatoptions]
set lineinput_transform [list _lineinput_as_raw $opt_inputformatoptions]
}
}
words {
words {
set lineinput_transform [list _lineinput_as_words $opt_inputformatoptions]
set lineinput_transform [list _lineinput_as_words $opt_inputformatoptions]
}
}
}
}
switch -- $opt_outputformat {
switch -- $opt_outputformat {
tcl {
tcl {
set lineoutput_transform [list _lineoutput_as_tcl $opt_outputformatoptions]
set lineoutput_transform [list _lineoutput_as_tcl $opt_outputformatoptions]
@ -1051,13 +1016,13 @@ namespace eval natsort {
set lineoutput_transform [list _lineoutput_as_csv $opt_outputformatoptions]
set lineoutput_transform [list _lineoutput_as_csv $opt_outputformatoptions]
}
}
raw {
raw {
set lineoutput_transform [list _lineoutput_as_raw $opt_outputformatoptions]
set lineoutput_transform [list _lineoutput_as_raw $opt_outputformatoptions]
}
}
words {
words {
set lineoutput_transform [list _lineoutput_as_words $opt_outputformatoptions]
set lineoutput_transform [list _lineoutput_as_words $opt_outputformatoptions]
}
}
}
}
if {("data" in $opt_inputformatapply) || ("index" in $opt_inputformatapply)} {
if {("data" in $opt_inputformatapply) || ("index" in $opt_inputformatapply)} {
if {$opt_inputformat eq "raw"} {
if {$opt_inputformat eq "raw"} {
set tf_stringlist $stringlist
set tf_stringlist $stringlist
@ -1102,7 +1067,7 @@ namespace eval natsort {
}
}
}
}
#puts stdout "colkeys: $colkeys"
#puts stdout "colkeys: $colkeys"
if {$opt_inputformat eq "raw"} {
if {$opt_inputformat eq "raw"} {
#no inputformat was applied - can just use stringlist
#no inputformat was applied - can just use stringlist
foreach value $stringlist ck $colkeys {
foreach value $stringlist ck $colkeys {
@ -1114,7 +1079,7 @@ namespace eval natsort {
foreach keyinput $tf_index_stringlist datavalue $tf_data_stringlist ck $colkeys {
foreach keyinput $tf_index_stringlist datavalue $tf_data_stringlist ck $colkeys {
#data may or may not have been transformed
#data may or may not have been transformed
#column index may or may not have been built with transformed data
#column index may or may not have been built with transformed data
set contentindex [build_key $keyinput $splitchars $topdict $tagconfig $debug]
set contentindex [build_key $keyinput $splitchars $topdict $tagconfig $debug]
set colindex [build_key $ck $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)
lappend keylist ${colindex}-${contentindex}-$datavalue ;#note: entire value used for final sort disambiguation (can be whitespace that was ignored in indexing)
set str [overtype::left $leftcol [lindex $stringlist $i]]
set str [overtype::left $leftcol [lindex $stringlist $i]]
} else {
} else {
set str [overtype::left $leftcol ...]]
set str [overtype::left $leftcol ...]]
}
}
puts stdout " $str $idxpart"
puts stdout " $str $idxpart"
incr r
incr r
}
}
#puts stdout "|> '[lindex $stringlist $i]'"
#puts stdout "|> '[lindex $stringlist $i]'"
#puts stdout "|> [lindex $keylist $i]"
#puts stdout "|> [lindex $keylist $i]"
}
}
puts stdout "|debug> topdict: $topdict"
puts stdout "|debug> topdict: $topdict"
puts stdout "|debug> splitchars: $splitchars"
puts stdout "|debug> splitchars: $splitchars"
}
}
@ -1229,26 +1192,25 @@ namespace eval natsort {
set topchars [string trim [dict get $args -topchars]]
set topchars [string trim [dict get $args -topchars]]
set topdot [expr {"." in $topchars}]
set topdot [expr {"." in $topchars}]
set topunderscore [expr {"_" in $topchars}]
set topunderscore [expr {"_" in $topchars}]
sqlite3 db_natsort2 $db
sqlite3 db_natsort2 $db
#--
#--
#our table must handle the name with the greatest number of numeric/non-numeric splits.
#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.
#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.
#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.
# 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 maxsegments 0
#--
#--
set prefix "idx"
set prefix "idx"
#note - there will be more columns in the sorting table than segments.
#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')
# (a segment equals one of the numeric & non-numeric string portions returned from 'split_numeric_sgements')
#---------------------------
#---------------------------
# consider
# consider
# a123b.v1.2.txt
# a123b.v1.2.txt
# a123b.v1.3beta1.txt
# a123b.v1.3beta1.txt
# these have the following segments:
# these have the following segments:
# a 123 b.v 1 . 2 .txt
# a 123 b.v 1 . 2 .txt
@ -1259,9 +1221,9 @@ namespace eval natsort {
#
#
# for example when the data has any elements in a segment position that are numeric (e.g 0001 123)
# 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)
# - 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
# 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.
#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.
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 "\$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 ")"
append sql_insert ")"
set segments [split_numeric_segments $nm]
set segments [split_numeric_segments $nm]
if {![string length [string trim [lindex $segments 0]]]} {
if {![string length [string trim [lindex $segments 0]]]} {
if {[string is digit [string trim [lindex $segments 1]]]} {
if {[string is digit [string trim [lindex $segments 1]]]} {
@ -1372,7 +1332,7 @@ namespace eval natsort {
}
}
set rawdata($c) [string trim $seg]
set rawdata($c) [string trim $seg]
} else {
} else {
#pure text column
#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
#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)}
#catch {unset indata($c)}
set indata($c) [string trim $seg]
set indata($c) [string trim $seg]
@ -1386,14 +1346,14 @@ namespace eval natsort {
}
}
set orderedlist [list]
set orderedlist [list]
if {$debug} {
if {$debug} {
db_natsort2 eval {select * from pragma_table_info('natsort')} rowdata {
db_natsort2 eval {select * from pragma_table_info('natsort')} rowdata {
parray rowdata
parray rowdata
}
}
}
}
set orderby "order by "
set orderby "order by "
foreach cname $ordered_column_names {
foreach cname $ordered_column_names {
if {[string match "idx*" $cname]} {
if {[string match "idx*" $cname]} {
append orderby "$cname ASC NULLS LAST,"
append orderby "$cname ASC NULLS LAST,"
@ -1403,7 +1363,7 @@ namespace eval natsort {
}
}
append orderby " name ASC"
append orderby " name ASC"
#append orderby " NULLS LAST" ;#??
#append orderby " NULLS LAST" ;#??
#e.g "order by idx0 ASC, raw0 ASC, idx1 ASC .... name ASC"
#e.g "order by idx0 ASC, raw0 ASC, idx1 ASC .... name ASC"
if {$debug} {
if {$debug} {
puts stdout "orderby clause: $orderby"
puts stdout "orderby clause: $orderby"
@ -1424,14 +1384,14 @@ namespace eval natsort {
#puts stdout "$rowdata(name)"
#puts stdout "$rowdata(name)"
lappend orderedlist $rowdata(name)
lappend orderedlist $rowdata(name)
}
}
db_natsort2 close
db_natsort2 close
return $orderedlist
return $orderedlist
}
}
}
}
#application section e.g this file might be linked from /usr/local/bin/natsort
#application section e.g this file might be linked from /usr/local/bin/natsort
namespace eval natsort {
namespace eval natsort {
namespace import ::flagfilter::check_flags
namespace import ::flagfilter::check_flags
@ -1440,9 +1400,9 @@ namespace eval natsort {
if {[info script] eq ""} {
if {[info script] eq ""} {
return 0
return 0
}
}
#see https://wiki.tcl-lang.org/page/main+script
#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)
#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)
catch {package require $library 1-0} ;#ensure pkg system has loaded/searched for everything for the path of the specified library (using unsatisfiable version range)
catch {package require $library 1-0} ;#ensure pkg system has loaded/searched for everything for the path of the specified library (using unsatisfiable version range)
if {[file pathtype $modulefoldername] eq "absolute"} {
if {[file pathtype $modulefoldername] eq "absolute"} {
append debug \n "input:[ansistring VIEW -lf 1 -vt 1 $new0] before row:$o_cursor_row after row: $result_row before col:$o_cursor_col after col:$result_col"
append debug \n "input:[ansistring VIEW -lf 1 -vt 1 $new0] before row:$o_cursor_row after row: $result_row before col:$o_cursor_col after col:$result_col"
package require textblock
package require textblock
set debug [textblock::frame -type $frametype -checkargs 0 -buildcache 0 $debug]
set debug [textblock::frame -type $frametype -checkargs 0 -buildcache 0 $debug]
#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"
#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 " "] ;#only default the general types - these form defaults for more specific types if they're missing
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
#unknown order of keys specified by user - validate before creating vars as we need more general elements to be available as defaults
