From d1a17624035b3869a7143bc2cad58fac697a789e Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Tue, 12 Dec 2023 11:21:23 +1100 Subject: [PATCH] make.tcl fixes, commandline script.tcl execution fixes, layout template updates --- .fossil-settings/ignore-glob | 1 + src/bootsupport/modules/natsort-0.1.1.5.tm | 1886 ++++++++++++++ src/bootsupport/modules/oolib-0.1.tm | 195 ++ src/bootsupport/modules/overtype-1.5.0.tm | 1039 ++++++++ src/bootsupport/modules/punk/du-0.1.0.tm | 629 ++++- src/bootsupport/modules/punk/mix-0.2.tm | 1484 +---------- src/bootsupport/modules/punk/repo-0.1.1.tm | 26 +- src/bootsupport/modules/punk/winpath-0.1.0.tm | 187 +- src/bootsupport/modules/punkcheck-0.1.0.tm | 1984 ++++++++++++++ src/doc/include/general.inc | 2 +- src/make.tcl | 441 +++- .../module/template_unversioned.tm | 50 - src/modules/platform-1.0.17.tm | 428 --- src/modules/platform/shell-1.1.4.tm | 241 -- src/modules/punk-0.1.tm | 55 +- src/modules/punk/ansi-999999.0a1.0.tm | 2 +- src/modules/punk/console-999999.0a1.0.tm | 10 +- src/modules/punk/mix/base-0.1.tm | 41 +- src/modules/punk/mix/cli-0.3.tm | 252 +- .../mix/commandset/buildsuite-999999.0a1.0.tm | 2 +- .../punk/mix/commandset/doc-999999.0a1.0.tm | 181 ++ .../punk/mix/commandset/doc-buildversion.txt | 3 + .../mix/commandset/layout-999999.0a1.0.tm | 2 +- .../mix/commandset/module-999999.0a1.0.tm | 8 +- .../mix/commandset/project-999999.0a1.0.tm | 130 +- .../mix/templates/layouts/project/.gitignore | 1 + .../src/bootsupport/include_modules.config | 6 + .../src/bootsupport/modules/cksum-1.1.4.tm | 200 ++ .../src/bootsupport/modules/cmdline-1.5.2.tm | 933 +++++++ .../bootsupport/modules/fileutil-1.16.1.tm | 2311 +++++++++++++++++ .../bootsupport/modules/natsort-0.1.1.5.tm | 1886 ++++++++++++++ .../src/bootsupport/modules/oolib-0.1.tm | 195 ++ .../src/bootsupport/modules/overtype-1.5.0.tm | 1039 ++++++++ .../src/bootsupport/modules/punk/du-0.1.0.tm | 1308 ++++++++++ .../src/bootsupport/modules/punk/mix-0.2.tm | 15 + .../bootsupport/modules/punk/repo-0.1.1.tm | 1232 +++++++++ .../bootsupport/modules/punk/winpath-0.1.0.tm | 266 ++ .../bootsupport/modules/punkcheck-0.1.0.tm | 299 ++- .../bootsupport/modules/struct/set-2.2.3.tm | 189 ++ .../src/bootsupport/modules/struct/sets.tcl | 189 ++ .../src/bootsupport/modules/struct/sets_c.tcl | 93 + .../bootsupport/modules/struct/sets_tcl.tcl | 452 ++++ .../project/src/doc/include/changes_0.1.inc | 31 +- .../templates/layouts/project/src/make.tcl | 183 +- .../basic/src/bootsupport/modules/README.md | 24 + .../src/sample.vfs/modules/shellthread-1.6.tm | 4 + src/modules/punk/overlay-0.1.tm | 17 +- src/modules/punk/repl-0.1.tm | 3 +- src/modules/punkcheck-0.1.0.tm | 299 ++- src/modules/shellfilter-0.1.8.tm | 69 +- src/modules/shellrun-0.1.tm | 47 +- src/modules/shellthread-1.6.tm | 66 +- src/modules/zzzload-999999.0a1.0.tm | 40 +- src/punk86.vfs/lib/app-punk/repl.tcl | 1 + src/punk86.vfs/lib/app-shellspy/shellspy.tcl | 183 +- src/runtime/mapvfs.config | 16 +- 56 files changed, 17897 insertions(+), 2979 deletions(-) create mode 100644 src/bootsupport/modules/natsort-0.1.1.5.tm create mode 100644 src/bootsupport/modules/oolib-0.1.tm create mode 100644 src/bootsupport/modules/overtype-1.5.0.tm create mode 100644 src/bootsupport/modules/punkcheck-0.1.0.tm delete mode 100644 src/mixtemplates/module/template_unversioned.tm delete mode 100644 src/modules/platform-1.0.17.tm delete mode 100644 src/modules/platform/shell-1.1.4.tm create mode 100644 src/modules/punk/mix/commandset/doc-999999.0a1.0.tm create mode 100644 src/modules/punk/mix/commandset/doc-buildversion.txt create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/include_modules.config create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/cksum-1.1.4.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/cmdline-1.5.2.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/fileutil-1.16.1.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/natsort-0.1.1.5.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/oolib-0.1.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/overtype-1.5.0.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/du-0.1.0.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/mix-0.2.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/repo-0.1.1.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/winpath-0.1.0.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/struct/set-2.2.3.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/struct/sets.tcl create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/struct/sets_c.tcl create mode 100644 src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/struct/sets_tcl.tcl create mode 100644 src/modules/punk/mix/templates/layouts/project/src/mixtemplates/layouts/basic/src/bootsupport/modules/README.md diff --git a/.fossil-settings/ignore-glob b/.fossil-settings/ignore-glob index 3f64cd8a..f4f7b089 100644 --- a/.fossil-settings/ignore-glob +++ b/.fossil-settings/ignore-glob @@ -1,4 +1,5 @@ .git +CVS bin lib #The directory for compiled/built Tcl modules diff --git a/src/bootsupport/modules/natsort-0.1.1.5.tm b/src/bootsupport/modules/natsort-0.1.1.5.tm new file mode 100644 index 00000000..0dcf57e7 --- /dev/null +++ b/src/bootsupport/modules/natsort-0.1.1.5.tm @@ -0,0 +1,1886 @@ +#! /usr/bin/env tclsh + + +package require flagfilter +namespace import ::flagfilter::check_flags + +namespace eval natsort { + proc scriptdir {} { + set possibly_linked_script [file dirname [file normalize [file join [info script] ...]]] + if {[file isdirectory $possibly_linked_script]} { + return $possibly_linked_script + } else { + return [file dirname $possibly_linked_script] + } + } + tcl::tm::add [scriptdir] +} + + +namespace eval natsort { + variable stacktrace_on 0 + + proc do_error {msg {then error}} { + #note we exit or error out even if debug selected - as every do_error call is meant to interrupt code processing at the site of call + #this is not just a 'logging' call even though it has log-like descriptors + lassign $then type code + if {$code eq ""} { + set code 1 + } + set type [string tolower $type] + set levels [list debug info notice warn error critical] + if {$type in [concat $levels exit]} { + puts stderr "|$type> $msg" + } else { + puts stderr "|>natsort_call_err> unable to interpret 2nd argument to do_error: '$then' should be one of '$levels' or 'exit '" + } + if {$::tcl_interactive} { + #may not always be desirable - but assumed to be more useful not to exit despite request, to aid in debugging + if {[string tolower $type] eq "exit"} { + puts stderr " (exit suppressed due to tcl_interactive - raising error instead)" + if {![string is digit -strict $code]} { + puts stderr "|>natsort_call_err> unable to interpret 2nd argument to do_error: '$then' should be: 'exit '" + } + } + return -code error $msg + } else { + if {$type ne "exit"} { + return -code error $msg + } else { + if {[string is digit -strict $code]} { + exit $code + } else { + puts stderr "|>natsort_call_err> unable to interpret 2nd argument to do_error: '$then' should be 'error' or 'exit '" + return -code error $msg + } + } + } + } + + + + + + + variable debug 0 + variable testlist + set testlist { + 00.test-firstposition.txt + 0001.blah.txt + 1.test-sorts-after-all-leadingzero-number-one-equivs.txt + 1010.thousand-and-ten.second.txt + 01010.thousand-and-ten.first.txt + 0001.aaa.txt + 001.zzz.txt + 08.octal.txt-last-octal + 008.another-octal-first-octal.txt + 08.again-second-octal.txt + 001.a.txt + 0010.reconfig.txt + 010.etc.txt + 005.etc.01.txt + 005.Etc.02.txt + 005.123.abc.txt + 200.somewhere.txt + 2zzzz.before-somewhere.txt + 00222-after-somewhere.txt + 005.00010.abc.txt + 005.a3423bc.00010.abc.txt + 005.001.abc.txt + 005.etc.1010.txt + 005.etc.010.txt + 005.etc.10.txt + " 005.etc.10.txt" + 005.etc.001.txt + 20.somewhere.txt + 4611686018427387904999999999-bignum.txt + 4611686018427387903-bigishnum.txt + 9223372036854775807-bigint.txt + etca-a + etc-a + etc2-a + a0001blah.txt + a010.txt + winlike-sort-difference-0.1.txt + winlike-sort-difference-0.1.1.txt + a1.txt + b1-a0001blah.txt + b1-a010.txt + b1-a1.txt + -a1.txt + --a1.txt + --a10.txt + 2.high-two.yml + 02.higher-two.yml + reconfig.txt + _common.stuff.txt + CASETEST.txt + casetest.txt + something.txt + some~thing.txt + someathing.txt + someThing.txt + thing.txt + thing_revised.txt + thing-revised.txt + "thing revised.txt" + "spacetest.txt" + " spacetest.txt" + " spacetest.txt" + "spacetest2.txt" + "spacetest 2.txt" + "spacetest02.txt" + name.txt + name2.txt + "name .txt" + "name2 .txt" + blah.txt + combined.txt + a001.txt + .test + .ssh + "Feb 10.txt" + "Feb 8.txt" + 1ab23v23v3r89ad8a8a8a9d.txt + "Folder (10)/file.tar.gz" + "Folder/file.tar.gz" + "Folder (1)/file (1).tar.gz" + "Folder (1)/file.tar.gz" + "Folder (01)/file.tar.gz" + "Folder1/file.tar.gz" + "Folder(1)/file.tar.gz" + + } + lappend testlist "Some file.txt" + lappend testlist " Some extra file1.txt" + lappend testlist " Some extra file01.txt" + lappend testlist " some extra file1.txt" + lappend testlist " Some extra file003.txt" + lappend testlist " Some file.txt" + lappend testlist "Some extra file02.txt" + lappend testlist "Program Files (x86)" + lappend testlist "01999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999991-bigger-pathologically-bignum.txt" + lappend testlist "199999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-pathologically-bignum.txt" + lappend testlist "29999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-smaller-pathologically-bignum.txt" + lappend testlist "199999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-pathologically-bignum.txt with (more 1.txt" + lappend testlist "199999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-pathologically-bignum.txt with (more 01.txt" + lappend testlist "a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1.pathological-num-nonnum-swapping-leadzero-should-be-first.txt" + lappend testlist "a1a1a1a1a1a1a1a1a1a1a1a01a1a1a1a1a1a1a1a1a1a1a1a1.pathological-num-nonnum-swapping-leadzero-should-be-first.txt" + lappend testlist "b1b1b1b1.txt" + lappend testlist "b1b01z1z1.txt" + lappend testlist "c1c111c1.txt" + lappend testlist "c1c1c1c1.txt" + + namespace eval overtype { + proc right {args} { + # @d !todo - implement overflow, length checks etc + + if {[llength $args] < 2} { + error {usage: ?-overflow [1|0]? undertext overtext} + } + foreach {undertext overtext} [lrange $args end-1 end] break + + set opt(-overflow) 0 + array set opt [lrange $args 0 end-2] + + + set olen [string length $overtext] + set ulen [string length $undertext] + + if {$opt(-overflow)} { + return [string range $undertext 0 end-$olen]$overtext + } else { + if {$olen > $ulen} { + set diff [expr {$olen - $ulen}] + return [string range $undertext 0 end-$olen][string range $overtext 0 end-$diff] + } else { + return [string range $undertext 0 end-$olen]$overtext + } + } + } + proc left {args} { + # @c overtype starting at left (overstrike) + # @c can/should we use something like this?: 'format "%-*s" $len $overtext + + if {[llength $args] < 2} { + error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} + } + foreach {undertext overtext} [lrange $args end-1 end] break + + set opt(-ellipsis) 0 + set opt(-ellipsistext) {...} + set opt(-overflow) 0 + array set opt [lrange $args 0 end-2] + + + set len [string length $undertext] + set overlen [string length $overtext] + set diff [expr {$overlen - $len}] + + #puts stdout "====================>overtype: datalen:$len overlen:$overlen diff:$diff" + #puts stdout "====================>overtype: data: $overtext" + if {$diff > 0} { + if {$opt(-overflow)} { + return $overtext + } else { + if {$opt(-ellipsis)} { + return [overtype::left [string range $overtext 0 [expr {$len -1}]] $opt(-ellipsistext)] + } else { + return [string range $overtext 0 [expr {$len -1}]] + } + } + } else { + return "$overtext[string range $undertext $overlen end]" + } + } + + } + + #considered using hex to make large numbers more compact for viewing in debug output - but it's not that much shorter and probably obscures more than it helps. + proc hex2dec {largeHex} { + set res 0 + set largeHex [string map [list _ ""] $largeHex] + foreach hexDigit [split $largeHex {}] { + set new 0x$hexDigit + set res [expr {16*$res + $new}] + } + return $res + } + proc dec2hex {decimalNumber} { + format %4.4llX $decimalNumber + } + proc trimzero {number} { + set trimmed [string trimleft $number 0] + if {[string length $trimmed] == 0} { + set trimmed 0 + } + return $trimmed + } + #todo - consider human numeric split + #e.g consider SI suffixes k|KMGTPEZY in that order + + #in this context, for natural sorting - numeric segments don't contain underscores or other punctuation such as . - + etc. + #review - what about unicode equivalents such as wide numerals \UFF10 to \UFF19? unicode normalization? + proc split_numeric_segments {name} { + set segments [list] + while {[string length $name]} { + if {[scan $name {%[0-9]%n} chunk len] == 2} { + lappend segments $chunk + set name [string range $name $len end] + } + if {[scan $name {%[^0-9]%n} chunk len] == 2} { + lappend segments $chunk + set name [string range $name $len end] + } + } + return $segments + } + + proc padleft {str count {ch " "}} { + set val [string repeat $ch $count] + append val $str + set diff [expr {max(0,$count - [string length $str])}] + set offset [expr {max(0,$count - $diff)}] + set val [string range $val $offset end] + } + + + # Sqlite may have limited collation sequences available in default builds. + # with custom builds - there may be others such as 'natsort' - see https://sqlite.org/forum/forumpost/e4dc6f3331 + # This is of limited use with the few builtin collations available in 2023 ie binary,nocase & rtrim + # but may provide a quicker,flexible sort option, especially if/when more collation sequences are added to sqlite + # There are also prebuilt packages such as sqlite3-icu which allows things like "SELECT icu_load_collation('en_AU', 'australian');" + proc sort_sqlite {stringlist args} { + package require sqlite3 + + + set args [check_flags -caller natsort_sqlite -defaults [list -db :memory: -collate nocase -winlike 0 -topchars "\uFFFF" -debug 0 -splitchars [list / . - _] -extras {all}] -values $args] + set db [string trim [dict get $args -db]] + set collate [string trim [dict get $args -collate]] + set debug [string trim [dict get $args -debug]] + set topchars [string trim [dict get $args -topchars]] + + set topdot [expr {"." in $topchars}] + set topunderscore [expr {"_" in $topchars}] + + + sqlite3 db_sort_basic $db + set orderedlist [list] + db_sort_basic eval [string map [list %collate% $collate] {create table sqlitesort(index0 text COLLATE %collate%, name text COLLATE %collate%)}] + foreach nm $stringlist { + set segments [split_numeric_segments $nm] + set index "" + set s 0 + foreach seg $segments { + if {($s == 0) && ![string length [string trim $seg]]} { + #don't index leading space + } elseif {($s == 0) && ($topunderscore) && [string match _* [string trim $seg]]} { + append index "[padleft "0" 5]-d -100 topunderscore " + append index [string trim $seg] + } elseif {($s == 0) && ($topdot) && [string match .* [string trim $seg]]} { + append index "[padleft "0" 5]-d -50 topdot " + append index [string trim $seg] + } else { + if {[string is digit [string trim $seg]]} { + set basenum [trimzero [string trim $seg]] + set lengthindex "[padleft [string length $basenum] 5]-d" + append index "$lengthindex " + #append index [padleft $basenum 40] + append index $basenum + } else { + append index [string trim $seg] + } + } + incr s + } + puts stdout ">>$index" + db_sort_basic eval {insert into sqlitesort values($index,$nm)} + } + db_sort_basic eval [string map [list %collate% $collate] {select name from sqlitesort order by index0 COLLATE %collate% ASC, name COLLATE %collate% ASC }] { + lappend orderedlist $name + } + db_sort_basic close + return $orderedlist + } + + proc get_leading_char_count {str char} { + #todo - something more elegant? regex? + set count 0 + foreach c [split $str "" ] { + if {$c eq $char} { + incr count + } else { + break + } + } + return $count + } + proc stacktrace {} { + set stack "Stack trace:\n" + for {set i 1} {$i < [info level]} {incr i} { + set lvl [info level -$i] + set pname [lindex $lvl 0] + append stack [string repeat " " $i]$pname + + if {![catch {info args $pname} pargs]} { + foreach value [lrange $lvl 1 end] arg $pargs { + + if {$value eq ""} { + if {$arg != 0} { + info default $pname $arg value + } + } + append stack " $arg='$value'" + } + } else { + append stack " !unknown vars for $pname" + } + + append stack \n + } + return $stack + } + + proc get_char_count {str char} { + expr {[string length $str]-[string length [string map [list $char {}] $str]]} + } + + proc build_key {chunk splitchars topdict tagconfig debug} { + variable stacktrace_on + if {$stacktrace_on} { + puts stderr "+++>[stacktrace]" + } + + set index_map [list - "" _ ""] + #e.g - need to maintain the order + #a b.txt + #a book.txt + #ab.txt + #abacus.txt + + + set original_splitchars [dict get $tagconfig original_splitchars] + + # tag_dashes test moved from loop - review + set tag_dashes 0 + if {![string length [dict get $tagconfig last_part_text_tag]]} { + #winlike + set tag_dashes 1 + } + if {("-" ni $original_splitchars)} { + set tag_dashes 1 + } + if {$debug >= 3} { + puts stdout "START build_key chunk : $chunk" + puts stdout "START build_key splitchars : $splitchars $topdict $tagconfig NO tag dashes" + } + + + ## index_map will have no effect if we've already split on the char anyway(?) + #foreach m [dict keys $index_map] { + # if {$m in $original_splitchars} { + # dict unset index_map $m + # } + #} + + #if {![string length $chunk]} return + + set result "" + if {![llength $splitchars]} { + #no more structural splits - but we need to examine numeric/non-numeric segments at the lowest level. + # we are at a leaf in the recursive split hierarchy + + set s "" ;#we never actually split on "" (unless that was put in splitchars.. but it probably shouldn't be) + set parts [list $chunk] ;#important to treat as list or leading/trailing whitespace lost + + + } else { + set s [lindex $splitchars 0] + if {"spudbucket$s" in "[split $chunk {}]"} { + error "dead-branch spudbucket" + set partindex [build_key $chunk [lrange $splitchars 1 end] $topdict $tagconfig $debug] + if {[dict get $tagconfig showsplits]} { + set pfx "(1${s}=)" ;# = sorts before _ + set partindex ${pfx}$partindex + } + + return $partindex + } else { + set parts_below_index "" + + if {$s ni [split $chunk ""]} { + #$s can be an empty string + set parts [list $chunk] + } else { + set parts [split $chunk $s] ;#whitespace preserved - even if splitting on s that is not in string. + } + #assert - we have a splitchar $s that is in the chunk - so at least one part + if {(![string length $s] || [llength $parts] == 0)} { + error "buld_key assertion false empty split char and/or no parts" + } + + set pnum 1 ;# 1 based for clarity of reading index in debug output + set subpart_count [llength $parts] + + set sub_splits [lrange $splitchars 1 end] ;#pass same splitchars to each subpart + foreach p $parts { + set partindex [build_key $p $sub_splits $topdict $tagconfig $debug] + set lastpart [expr {$pnum == $subpart_count}] + + + ####################### + set showsplits [dict get $tagconfig showsplits] + #split prefixing experiment - maybe not suitable for general use - as it affects sort order + #note that pfx must be consistent until last one, no matter how many partnumbers there are in total. + # we don't want to influence sort order before reaching end. + #e.g for: + #(1.=)... + #(1._)...(2._)...(3.=) + #(1._)...(2.=) + #Note that this is probably more suitable for highly structure dependant sorts where the results are maybe less.. natural. + if {$showsplits} { + if {$lastpart} { + set pfx "(${pnum}${s}_" + #set pfx "(${pnum}${s}=)" ;# = sorts before _ + } else { + set pfx "(${pnum}${s}_" + } + append parts_below_index $pfx + } + ####################### + + if {$lastpart} { + if {[string length $p] && [string is digit $p]} { + set last_part_tag "<22${s}>" + } else { + set last_part_tag "<33${s}>" + } + + set last_part_text_tag [dict get $tagconfig last_part_text_tag] + #for -winlike 1 there is no tag configured. Windows explorer likes to put things in the order: + # module-0.1.1.tm + # module-0.1.1.2.tm + # module-0.1.tm + # arguably -winlike 0 is more natural/human + # module-0.1.tm + # module-0.1.1.tm + # module-0.1.1.2.tm + + if {[string length $last_part_text_tag]} { + #replace only the first text-tag (<30>) from the subpart_index + if {[string match "<30?>*" $partindex]} { + #give textual string index a specific tag for last part in split only. e.g <130> for lower than integers + set partindex "<130>[string range $partindex 5 end]" + } + #append parts_below_index $last_part_tag + } + #set partindex $last_part_tag$partindex + + + } + append parts_below_index $partindex + + + + if {$showsplits} { + if {$lastpart} { + set suffix "${pnum}${s}=)" ;# = sorts before _ + } else { + set suffix "${pnum}${s}_)" + } + append parts_below_index $suffix + } + + + incr pnum + } + append parts_below_index "" ;# don't add anything at the tail that may perturb sort order + + if {$debug >= 3} { + set pad [string repeat " " 20] + puts stdout "END build_key chunk : $chunk " + puts stdout "END build_key splitchars : $splitchars $topdict $tagconfig NO tag dashes" + puts stdout "END build_key ret below_index: $parts_below_index" + } + return $parts_below_index + + + } + } + + + + #puts stdout ">>>chunk:'$chunk'<<< split-on:$s parts: '$parts' splitchars: $splitchars -topdict:$topdict" + + + + + + #if {$chunk eq ""} { + # puts "___________________________________________!!!____" + #} + #puts stdout "-->chunk:$chunk $s parts:$parts" + + #puts stdout "---chunk:'$chunk' part:'$part' parts:'$parts' s:'$s'" + + + + + set segments [split_numeric_segments $chunk] ;#! + set stringindex "" + set segnum 0 + foreach seg $segments { + #puts stdout "=================---->seg:$seg segments:$segments" + #-strict ? + if {[string length $seg] && [string is digit $seg]} { + set basenum [trimzero [string trim $seg]] + set lengthindex "[padleft [string length $basenum] 4]d" + #append stringindex "<20>$lengthindex $basenum $seg" + } else { + set c1 [string range $seg 0 0] + #puts stdout "==============> c1'$c1' topdict: $topdict stringindex:$stringindex" + + if {$c1 in [dict keys $topdict]} { + set tag [dict get $topdict $c1] + #append stringindex "${tag}$c1" + #set seg [string range $seg 1 end] + } + #textindex + set leader "<30>" + set idx $seg + set idx [string trim $idx] + set idx [string tolower $idx] + set idx [string map $index_map $idx] + + + + + + #set the X-c count to match the length of the index - not the raw data + set lengthindex "[padleft [string length $idx] 4]c" + + #append stringindex "${leader}$idx $lengthindex $texttail" + } + } + + if {[llength $parts] != 1} { + error "build_key assertion fail llength parts != 1 parts:$parts" + } + + set segtail_clearance_buffer " " ;#space to clear other split indicators if using showsplits + set segtail $segtail_clearance_buffer + append segtail "\[" + set grouping "" + set pnum 0 + foreach p $parts { + set sublen_list [list] + set subsegments [split_numeric_segments $p] + set i 0 + + set partsorter "" + foreach sub $subsegments { + ##don't trim spaces here - it would be inconsistent. Some subs are pure whitespace - others have internal whitespace. e.g "a4 400b a b2" becomes "a 4 { } 400 {b a b} 2" + #mapping away all whitespace would be consistent, but not necessarily desirable. If it's in the index_map it'll happen anyway - so we don't do it manually here except for evaluating conditions. + set test_trim [string trim $sub] + set str $sub + set str [string tolower $str] + set str [string map $index_map $str] + if {[string length $test_trim] && [string is digit $test_trim]} { + append partsorter [trimzero $str] + } else { + append partsorter "$str" + } + append partsorter + } + + + foreach sub $subsegments { + + if {[string length $sub] && [string is digit $sub]} { + set basenum [trimzero [string trim $sub]] + set subequivs $basenum + set lengthindex "[padleft [string length $subequivs] 4]d " + set idx "$lengthindex [padleft $basenum 10]" ;#todo - cycle through data and determine longest + set tail [overtype::left [string repeat " " 10] $sub] + #set tail "" + } else { + set idx "" + + + set lookahead [lindex $subsegments $i+1] + if {![string length $lookahead]} { + set zeronum "[padleft 0 4]d0" + } else { + set zeronum "" + } + set subequivs $sub + #set subequivs [string trim $subequivs] + set subequivs [string tolower $subequivs] + set subequivs [string map $index_map $subequivs] + + append idx $subequivs + append idx $zeronum + + set idx $subequivs + + + # + + set ch "-" + if {$tag_dashes} { + #puts stdout "____TAG DASHES" + #winlike + set numleading [get_leading_char_count $seg $ch] + if {$numleading > 0} { + set texttail "<31-leading[padleft $numleading 4]$ch>" + } else { + set texttail "<30>" + } + set numothers [expr {[get_char_count $seg $ch] - $numleading}] + if {$debug >= 2} { + puts stdout "____dashcount: [get_char_count $seg $ch] numothers: $numothers" + } + if {$numothers > 0} { + append texttail "<31-others[padleft $numothers 4]$ch>" + } else { + append textail "<30>" + } + } else { + set texttail "<30>" + } + + + + + #set idx $partsorter + set tail "" + #set tail [string tolower $sub] ;#raw + #set tail $partsorter + #append tail ":[string tolower $p]" ;#we need the whole part - even though it makes the index much larger. !todo - tagconfig switch to toggle case sensitive sorting + } + + append grouping "$idx $tail|$s" + incr i + } + + + + + + if {$p eq ""} { + # no subsegments.. + set zeronum "[padleft 0 4]d0" + #append grouping "\u000$zerotail" + append grouping ".$zeronum" + } + + #append grouping | + #append grouping $s + #foreach len $sublen_list { + # append segtail "<[padleft $len 3]>" + #} + incr pnum + } + set grouping [string trimright $grouping $s] + append grouping "[padleft [llength $parts] 4]" + append segtail $grouping + + + #append segtail " <[padleft [llength $parts] 4]>" + + append segtail "\]" + + + #if {[string length $seg] && [string is digit $seg]} { + # append segtail "<20>" + #} else { + # append segtail "<30>" + #} + append stringindex $segtail + + incr segnum + + + + + lappend indices $stringindex + + if {[llength $indices] > 1} { + puts stderr "INDICES [llength $indices]: $stringindex" + error "build_key assertion error deadconcept indices" + } + + #topchar handling on splitter characters + #set c1 [string range $chunk 0 0] + if {$s in [dict keys $topdict]} { + set tag [dict get $topdict $s] + set joiner [string map [list ">" "$s>"] ${tag}] + #we have split on this character $s so if the first part is empty string then $s was a leading character + # we need to bring a tag out front for this, or it will be dominated by the leading sections-remaing tag + # (since the empty string produces no tag of it's own - ?) + if {[string length [lindex $parts 0]] == 0} { + set prefix ${joiner} + } else { + set prefix "" + } + } else { + #use standard character-data positioning tag if no override from topdict + set joiner "<30J>$s" + set prefix "" + } + + + set contentindex $prefix[join $indices $joiner] + if {[string length $s]} { + set split_indicator "" + } else { + set split_indicator "" + + } + if {![string length $s]} { + set s ~ + } + + #return "[overtype::left [string repeat { } 80] $contentindex][overtype::left [string repeat { } 10] [list $s $chunk]]" + #return $contentindex$split_indicator + #return [overtype::left [string repeat - 40] $contentindex] + + if {$debug >= 3} { + puts stdout "END build_key chunk : $chunk" + puts stdout "END build_key splitchars : $splitchars $topdict $tagconfig NO tag dashes" + puts stdout "END build_key ret contentidx : $contentindex" + } + return $contentindex + } + + #---------------------------------------- + #line-processors - data always last argument - opts can be empty string + #all processor should accept empty opts and ignore opts if they don't use them + proc _lineinput_as_tcl1 {opts line} { + set out "" + foreach i $line { + append out "$i " + } + set out [string range $out 0 end-1] + return $out + } + #should be equivalent to above + proc _lineinput_as_tcl {opts line} { + return [concat {*}$line] + } + #will put extra tcl quoting if it was already tcl-shaped e.g text "a" -> {"a"} + proc _lineoutput_as_tcl {opts line} { + return [regexp -inline -all {\S+} $line] + } + + proc _lineinput_as_raw {opts line} { + return $line + } + proc _lineoutput_as_raw {opts line} { + return $line + } + + #words is opposite of tcl + proc _lineinput_as_words {opts line} { + #wordlike_parts + return [regexp -inline -all {\S+} $line] + } + proc _lineoutput_as_words {opts line} { + return [concat {*}$line] + } + + #opts same as tcllib csv::split - except without the 'line' element + #?-alternate? ?sepChar? ?delChar? + proc _lineinput_as_csv {opts line} { + package require csv + if {[lindex $opts 0] eq "-alternate"} { + return [csv::split -alternate $line {*}[lrange $opts 1 end]] + } else { + return [csv::split $line {*}$opts] + } + } + #opts same as tcllib csv::join + #?sepChar? ?delChar? ?delMode? + proc _lineoutput_as_csv {opts line} { + package require csv + return [csv::join $line {*}$opts] + } + #---------------------------------------- + proc sort {stringlist args} { + #puts stdout "natsort::sort args: $args" + variable debug + if {![llength $stringlist]} return + + #allow pass through of the check_flags flag -debugargs so it can be set by the caller + set debugargs 0 + if {[set posn [lsearch $args -debugargs]] >=0} { + if {$posn == [llength $args]-1} { + #-debugargs at tail of list + set debugargs 1 + } else { + set debugargs [lindex $args $posn+1] + } + } + + #-return flagged|defaults doesn't work Review. + #flagfilter global processor/allocator not working 2023-08 + set args [check_flags \ + -caller natsort::sort \ + -return supplied|defaults \ + -debugargs $debugargs \ + -defaults [list -collate nocase \ + -winlike 0 \ + -splits "\uFFFF" \ + -topchars {. _} \ + -showsplits 1 \ + -sortmethod ascii \ + -collate "\uFFFF" \ + -inputformat raw \ + -inputformatapply {index data} \ + -inputformatoptions "" \ + -outputformat raw \ + -outputformatoptions "" \ + -cols "\uFFFF" \ + -debug 0 -db "" -stacktrace 0 -splits "\uFFFF" -showsplits 0] \ + -required {all} \ + -extras {none} \ + -commandprocessors {} \ + -values $args] + + #csv unimplemented + + set winlike [dict get $args -winlike] + set topchars [dict get $args -topchars] + set cols [dict get $args -cols] + set debug [dict get $args -debug] + set stacktrace [dict get $args -stacktrace] + set showsplits [dict get $args -showsplits] + set splits [dict get $args -splits] + set sortmethod [dict get $args -sortmethod] + set opt_collate [dict get $args -collate] + set opt_inputformat [dict get $args -inputformat] + set opt_inputformatapply [dict get $args -inputformatapply] + set opt_inputformatoptions [dict get $args -inputformatoptions] + set opt_outputformat [dict get $args -outputformat] + set opt_outputformatoptions [dict get $args -outputformatoptions] + dict unset args -showsplits + dict unset args -splits + if {$debug} { + puts stdout "natsort::sort processed_args: $args" + if {$debug == 1} { + puts stdout "natsort::sort - try also -debug 2, -debug 3" + } + } + + #set sortmethod "-dictionary" ;# sorts a2b before a001b - possibly other strangenesses that are hard to reason about + + if {$sortmethod in [list dictionary ascii]} { + set sortmethod "-$sortmethod" + # -ascii is default for tcl lsort. + } else { + set sortmethod "-ascii" + } + + set allowed_collations [list nocase] + if {$opt_collate ne "\uFFFF"} { + if {$opt_collate ni $allowed_collations} { + error "natsort::sort unknown value for -collate option. Only acceptable value(s): $allowed_collations" + } + set nocaseopt "-$opt_collate" + } else { + set nocaseopt "" + } + set allowed_inputformats [list tcl raw csv words] + if {$opt_inputformat ni $allowed_inputformats} { + error "natsort::sort unknown value for -inputformat option. Only acceptable value(s): $allowed_inputformats" + } + set allowed_outputformats [list tcl raw csv words] + if {$opt_inputformat ni $allowed_outputformats} { + error "natsort::sort unknown value for -outputformat option. Only acceptable value(s): $allowed_outputformats" + } + + # + set winsplits [list / . _] + set commonsplits [list / . _ -] + #set commonsplits [list] + + set tagconfig [dict create] + dict set tagconfig last_part_text_tag "<19>" + if {$winlike} { + set splitchars $winsplits + #windows explorer sorts leading spaces at the top - which doesn't seem very helpful for keeping things together - but the explorer doesn't seem able to create leading spaces anyway. + set wintop [list "(" ")" { } {.} {_}] ;#windows specific order + foreach t $topchars { + if {$t ni $wintop} { + lappend wintop $t + } + } + set topchars $wintop + dict set tagconfig last_part_text_tag "" + } else { + set splitchars $commonsplits + } + if {$splits ne "\uFFFF"} { + set splitchars $splits + } + dict set tagconfig original_splitchars $splitchars + dict set tagconfig showsplits $showsplits + + #create topdict + set i 0 + set topdict [dict create] + foreach c $topchars { + incr i ;#start at 01 so that 00 reserved for final-split tag (allows x-0.1.txt to sort above x-0.1.1.txt by default. Use tagconfig to change, or choose -winlike 1 for explorer-like sorting) + dict set topdict $c "<0$i>" + } + set keylist [list] + + + if {$opt_inputformat eq "tcl"} { + set lineinput_transform [list _lineinput_as_tcl $opt_inputformatoptions] + } elseif {$opt_inputformat eq "csv"} { + set lineinput_transform [list _lineinput_as_csv $opt_inputformatoptions] + } elseif {$opt_inputformat eq "raw"} { + set lineinput_transform [list _lineinput_as_raw $opt_inputformatoptions] + } elseif {$opt_inputformat eq "words"} { + set lineinput_transform [list _lineinput_as_words $opt_inputformatoptions] + } + if {$opt_outputformat eq "tcl"} { + set lineoutput_transform [list _lineoutput_as_tcl $opt_outputformatoptions] + } elseif {$opt_outputformat eq "csv"} { + set lineoutput_transform [list _lineoutput_as_csv $opt_outputformatoptions] + } elseif {$opt_outputformat eq "raw"} { + set lineoutput_transform [list _lineoutput_as_raw $opt_outputformatoptions] + } elseif {$opt_outputformat eq "words"} { + set lineoutput_transform [list _lineoutput_as_words $opt_outputformatoptions] + } + + + if {("data" in $opt_inputformatapply) || ("index" in $opt_inputformatapply)} { + if {$opt_inputformat eq "raw"} { + set tf_stringlist $stringlist + } else { + set tf_stringlist [list] + foreach v $stringlist { + lappend tf_stringlist [{*}$lineinput_transform $v] + } + } + if {"data" in $opt_inputformatapply} { + set tf_data_stringlist $tf_stringlist + } else { + set tf_data_stringlist $stringlist + } + if {"index" in $opt_inputformatapply} { + set tf_index_stringlist $tf_stringlist + } else { + set tf_index_stringlist $stringlist + } + } else { + set tf_data_stringlist $stringlist + set tf_index_stringlist $stringlist + } + + + + if {$stacktrace} { + puts stdout [natsort::stacktrace] + set natsort::stacktrace_on 1 + } + if {$cols eq "\uFFFF"} { + set colkeys [lmap v $stringlist {}] + } else { + set colkeys [list] + foreach v $tf_index_stringlist { + set lineparts $v + set k [list] + foreach c $cols { + lappend k [lindex $lineparts $c] + } + lappend colkeys [join $k "_"] ;#use a common-split char - Review + } + } + #puts stdout "colkeys: $colkeys" + + if {$opt_inputformat eq "raw"} { + #no inputformat was applied - can just use stringlist + foreach value $stringlist ck $colkeys { + set contentindex [build_key $value $splitchars $topdict $tagconfig $debug] + set colindex [build_key $ck $splitchars $topdict $tagconfig $debug] + lappend keylist ${colindex}-${contentindex}-$value ;#note: entire raw value used for final sort disambiguation (can be whitespace that was ignored in indexing) + } + } else { + foreach keyinput $tf_index_stringlist datavalue $tf_data_stringlist ck $colkeys { + #data may or may not have been transformed + #column index may or may not have been built with transformed data + + set contentindex [build_key $keyinput $splitchars $topdict $tagconfig $debug] + set colindex [build_key $ck $splitchars $topdict $tagconfig $debug] + lappend keylist ${colindex}-${contentindex}-$datavalue ;#note: entire value used for final sort disambiguation (can be whitespace that was ignored in indexing) + } + } + #puts stderr "keylist: $keylist" + + ################################################################################################### + # Use the generated keylist to do the actual sorting + # select either the transformed or raw data as the corresponding output + ################################################################################################### + if {[string length $nocaseopt]} { + set sortcommand [list lsort $sortmethod $nocaseopt -indices $keylist] + } else { + set sortcommand [list lsort $sortmethod -indices $keylist] + } + if {$opt_outputformat eq "raw"} { + #raw output means no further transformations - it doesn't mean there wasn't a transform applied on the input side + #use the tf_data_stringlist in the output - which will be the same as the input stringlist if no input transform applied for data. + #(Also - it may or may not have been *sorted* on transformed data depending on whether 'index' was in $opt_inputformatapply) + foreach idx [{*}$sortcommand] { + lappend result [lindex $tf_data_stringlist $idx] + } + } else { + #we need to apply an output format + #The data may or may not have been transformed at input + foreach idx [{*}$sortcommand] { + lappend result [{*}$lineoutput_transform [lindex $tf_data_stringlist $idx]] + } + } + ################################################################################################### + + + + + + if {$debug >= 2} { + set screen_width 250 + set max_val 0 + set max_idx 0 + ##### calculate colum widths + foreach i [{*}$sortcommand] { + set len_val [string length [lindex $stringlist $i]] + if {$len_val > $max_val} { + set max_val $len_val + } + set len_idx [string length [lindex $keylist $i]] + if {$len_idx > $max_idx} { + set max_idx $len_idx + } + } + #### + set l_width [expr {$max_val + 1}] + set leftcol [string repeat " " $l_width] + set r_width [expr {$screen_width - $l_width - 1}] + set rightcol [string repeat " " $r_width] + set str [overtype::left $leftcol RAW] + puts stdout " $str Index with possibly transformed data at tail" + foreach i [{*}$sortcommand] { + #puts stdout "|d> [overtype::left $leftcol [lindex $stringlist $i] ] [lindex $keylist $i]" + set index [lindex $keylist $i] + set len_idx [string length $index] + set rowcount [expr {$len_idx / $r_width}] + if {($len_idx % $r_width) > 0} { + incr rowcount + } + set rows [list] + for {set r 0} {$r < $rowcount} {incr r} { + lappend rows [string range $index 0 $r_width-$r] + set index [string range $index $r_width end] + } + + set r 0 + foreach idxpart $rows { + if {$r == 0} { + #use the untransformed stringlist + set str [overtype::left $leftcol [lindex $stringlist $i]] + } else { + set str [overtype::left $leftcol ...]] + } + puts stdout " $str $idxpart" + incr r + } + #puts stdout "|> '[lindex $stringlist $i]'" + #puts stdout "|> [lindex $keylist $i]" + } + + puts stdout "|debug> topdict: $topdict" + puts stdout "|debug> splitchars: $splitchars" + } + return $result + } + + + + #Note that although leading whitespace isn't a commonly used feature of filesystem names - it's possible at least on FreeBSD,windows and linux so we should try to handle it sensibly. + proc sort_experiment {stringlist args} { + package require sqlite3 + + variable debug + set args [check_flags -caller natsort::sort \ + -defaults [dict create -db :memory: -collate nocase -nullvalue "->NULL<" -winlike 0 -topchars [list] -debug 0] \ + -extras {all} \ + -values $args] + set db [string trim [dict get $args -db]] + set collate [string trim [dict get $args -collate]] + set winlike [string trim [dict get $args -winlike]] + set debug [string trim [dict get $args -debug]] + set nullvalue [string trim [dict get $args -nullvalue]] + + + set topchars [string trim [dict get $args -topchars]] + + set topdot [expr {"." in $topchars}] + set topunderscore [expr {"_" in $topchars}] + + + sqlite3 db_natsort2 $db + #-- + #our table must handle the name with the greatest number of numeric/non-numeric splits. + #This means a single list member with pathological naming e.g a1a1a1a1a1a1a1a1a1a1a1.txt could greatly extend the number of columns and indices and affect performance. + #review: could be optimised to aggregate the tail into a single index, as the the extra columns won't assist in ordering, but make the table and query bigger. + # we should probably determine the longest common sequence of splits in the input list and add only one more index for the segment after that. + set maxsegments 0 + #-- + set prefix "idx" + + #note - there will be more columns in the sorting table than segments. + # (a segment equals one of the numeric & non-numeric string portions returned from 'split_numeric_sgements') + #--------------------------- + # consider + # a123b.v1.2.txt + # a123b.v1.3beta1.txt + # these have the following segments: + # a 123 b.v 1 . 2 .txt + # a 123 b.v 1 . 3 beta 1 .txt + #--------------------------- + # The first string has 7 segments (numbered 0 to 6) + # the second string has 9 segments + # + # for example when the data has any elements in a segment position that are numeric (e.g 0001 123) + # - then an index column with numeric equivalents will be created (e.g 0001 becomes 1), and any non-numeric values in that column will get mapped to a negative value (for special cases) or a high value such as NULL (with NULLS LAST sql support) + # + # when a segment + + #cycle through all strings - we cannot build tabledef as we go because the column type depends on whether all segments for a particular column are text vs int-equivalent. + array set segmentinfo {} + foreach nm $stringlist { + set segments [split_numeric_segments $nm] + if {![string length [string trim [lindex $segments 0]]]} { + if {[string is digit [string trim [lindex $segments 1]]]} { + #name is whitespace followed by a digit - special case - ignore the whitespace for numbers only. (whitespace still goes through to name column though) + set segments [lrange $segments 1 end] + } + } + + + set c 0 ;#start of index columns + if {[llength $segments] > $maxsegments} { + set maxsegments [llength $segments] + } + foreach seg $segments { + set seg [string trim $seg] + set column_exists [info exists segmentinfo($c,type)] + if {[string is digit $seg]} { + if {$column_exists} { + #override it (may currently be text or int) + set segmentinfo($c,type) "int" + } else { + #new column + set segmentinfo($c,name) ${prefix}$c + set segmentinfo($c,type) "int" + } + } else { + #text never overrides int + if {!$column_exists} { + set segmentinfo($c,name) ${prefix}$c + set segmentinfo($c,type) "text" + } + } + incr c + } + } + if {$debug} { + puts stdout "Largest number of num/non-num segments in data: $maxsegments" + #parray segmentinfo + } + + # + set tabledef "" + set ordered_column_names [list] + set ordered_segmentinfo_tags [lsort -dictionary [array names segmentinfo *]] + foreach k $ordered_segmentinfo_tags { + lassign [split $k ,] c tag + if {$tag eq "type"} { + set type [set segmentinfo($k)] + if {$type eq "int"} { + append tabledef "$segmentinfo($c,name) int," + } else { + append tabledef "$segmentinfo($c,name) text COLLATE $collate," + } + append tabledef "raw$c text COLLATE $collate," + lappend ordered_column_names $segmentinfo($c,name) + lappend ordered_column_names raw$c ;#additional index column not in segmentinfo + } + if {$tag eq "name"} { + #lappend ordered_column_names $segmentinfo($k) + } + } + append tabledef "name text" + + #puts stdout "tabledef:$tabledef" + + + db_natsort2 eval [string map [list %tabledef% $tabledef] {create table natsort(%tabledef%)}] + + + foreach nm $stringlist { + array unset intdata + array set intdata {} + array set rawdata {} + #init array and build sql values string + set sql_insert "insert into natsort values(" + for {set i 0} {$i < $maxsegments} {incr i} { + set intdata($i) "" + set rawdata($i) "" + append sql_insert "\$intdata($i),\$rawdata($i)," + } + append sql_insert "\$nm" ;#don't manipulate name value in any way - e.g must leave all whitespace as the sort must return exactly the same elements as in the original list. + append sql_insert ")" + + set segments [split_numeric_segments $nm] + if {![string length [string trim [lindex $segments 0]]]} { + if {[string is digit [string trim [lindex $segments 1]]]} { + #name is whitespace followed by a digit - special case - ignore the whitespace for numbers only. (whitespace still goes through to name column though) + set segments [lrange $segments 1 end] + } + } + set values "" + set c 0 + foreach seg $segments { + if {[set segmentinfo($c,type)] eq "int"} { + if {[string is digit [string trim $seg]]} { + set intdata($c) [trimzero [string trim $seg]] + } else { + catch {unset intdata($c)} ;#set NULL - sorts last + if {($c == 0) && ($topunderscore) && [string match _* [string trim $seg]]} { + set intdata($c) -100 + } + if {($c == 0) && ($topdot) && [string match .* [string trim $seg]]} { + set intdata($c) -50 + } + } + set rawdata($c) [string trim $seg] + } else { + #pure text column + #set intdata($c) [string trim $seg] ;#ignore leading/trailing whitespace - we sort first on trimmed version, then refine with the sort on rawdata index + #catch {unset indata($c)} + set indata($c) [string trim $seg] + set rawdata($c) $seg + } + #set rawdata($c) [string trim $seg]# + #set rawdata($c) $seg + incr c + } + db_natsort2 eval $sql_insert + } + + set orderedlist [list] + + if {$debug} { + db_natsort2 eval {select * from pragma_table_info('natsort')} rowdata { + parray rowdata + } + } + set orderby "order by " + + foreach cname $ordered_column_names { + if {[string match "idx*" $cname]} { + append orderby "$cname ASC NULLS LAST," + } else { + append orderby "$cname ASC," + } + } + append orderby " name ASC" + #append orderby " NULLS LAST" ;#?? + + #e.g "order by idx0 ASC, raw0 ASC, idx1 ASC .... name ASC" + if {$debug} { + puts stdout "orderby clause: $orderby" + } + db_natsort2 eval [string map [list %orderby% $orderby] {select * from natsort %orderby%}] rowdata { + set line "- " + #parray rowdata + set columnnames $rowdata(*) + #puts stdout "columnnames: $columnnames" + #[lsort -dictionary [array names rowdata] + append line "$rowdata(name) \n" + foreach nm $columnnames { + if {$nm ne "name"} { + append line "$nm: $rowdata($nm) " + } + } + #puts stdout $line + #puts stdout "$rowdata(name)" + lappend orderedlist $rowdata(name) + } + + db_natsort2 close + return $orderedlist + } +} + + +#application section e.g this file might be linked from /usr/local/bin/natsort +namespace eval natsort { + namespace import ::flagfilter::check_flags + + proc called_directly_namematch {} { + global argv0 + #see https://wiki.tcl-lang.org/page/main+script + #trailing ... let's us resolve symlinks in last component of the path (could be something else like ___ but ... seems unlikely to collide with anything in the filesystem) + if {[info exists argv0] + && + [file dirname [file normalize [file join [info script] ...]]] + eq + [file dirname [file normalize [file join $argv0 ...]]] + } { + return 1 + } else { + #puts stdout "norm info script: [file dirname [file normalize [file join [info script] ...]]]" + #puts stdout "norm argv0 : [file dirname [file normalize [file join $argv0 ...]]]" + return 0 + } + } + #Review issues around comparing names vs using inodes (esp with respect to samba shares) + proc called_directly_inodematch {} { + global argv0 + if {[info exists argv0] + && [file exists [info script]] && [file exists $argv0]} { + file stat $argv0 argv0Info + file stat [info script] scriptInfo + expr {$argv0Info(dev) == $scriptInfo(dev) + && $argv0Info(ino) == $scriptInfo(ino)} + } else { + return 0 + } + } + + set is_namematch [called_directly_namematch] + set is_inodematch [called_directly_inodematch] + #### + #review - reliability of mechanisms to determine direct calls + # we don't want application being called when being used as a library, but we need it to run if called directly or from symlinks etc + #-- choose a policy and leave the others commented. + #set is_called_directly $is_namematch + #set is_called_directly $is_inodematch + set is_called_directly [expr {$is_namematch || $is_inodematch}] + #set is_called_directly [expr {$is_namematch && $is_inodematch}] + ### + + + #puts stdout "called_directly_name: [called_directly_namematch] called_directly_inode: [called_directly_inodematch]" + + + # + + + proc test_pass_fail_message {pass {additional ""}} { + variable test_fail_msg + variable test_pass_msg + if {$pass} { + puts stderr $test_pass_msg + } else { + puts stderr $test_fail_msg + } + puts stderr $additional + } + + variable test_fail_msg "XXXXXXXXXXXX FAIL XXXXXXXXXXXXX" + variable test_pass_msg "------------ PASS -------------" + proc test_sort_1 {args} { + package require struct::list + puts stderr "---$args" + set args [check_flags -caller natsort:test_sort_1 -defaults [list -collate nocase -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 ] -values $args] + + puts stderr "test_sort_1 got args: $args" + + set unsorted_input { + 2.2.2 + 2.2.2.2 + 1a.1.1 + 1a.2.1.1 + 1.12.1 + 1.2.1.1 + 1.02.1.1 + 1.002b.1.1 + 1.1.1.2 + 1.1.1.1 + } + set input { +1.1.1 +1.1.1.2 +1.002b.1.1 +1.02.1.1 +1.2.1.1 +1.12.1 +1a.1.1 +1a.2.1.1 +2.2.2 +2.2.2.2 + } + + set sorted [natsort::sort $input {*}$args] + set is_match [struct::list equal $input $sorted] + + set msg "windows-explorer order" + + test_pass_fail_message $is_match $msg + puts stdout [string repeat - 40] + puts stdout INPUT + puts stdout [string repeat - 40] + foreach item $input { + puts stdout $item + } + puts stdout [string repeat - 40] + puts stdout OUTPUT + puts stdout [string repeat - 40] + foreach item $sorted { + puts stdout $item + } + test_pass_fail_message $is_match $msg + return [expr {!$is_match}] + } + proc test_sort_showsplits {args} { + package require struct::list + + set args [check_flags -caller natsort:test_sort_1 \ + -defaults [list -collate nocase -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 1 ] \ + -extras {all} \ + -values $args] + + set input1 { + a-b.txt + a.b.c.txt + b.c-txt + } + + + set input2 { + a.b.c.txt + a-b.txt + b.c-text + } + + foreach {msg testlist } [list "custom-order" $input1 "windows-explorer (should work with -winlike 1)" $input2] { + set sorted [natsort::sort $testlist {*}$args] + set is_match [struct::list equal $testlist $sorted] + + test_pass_fail_message $is_match $msg + puts stderr "INPUT" + puts stderr "[string repeat - 40]" + foreach item $testlist { + puts stdout $item + } + puts stderr "[string repeat - 40]" + puts stderr "OUTPUT" + puts stderr "[string repeat - 40]" + foreach item $sorted { + puts stdout $item + } + + test_pass_fail_message $is_match $msg + } + + #return [expr {!$is_match}] + + } + + #tcl dispatch order - non flag items up front + #trailing flags are paired even if supplied as solo flags e.g -l becomes -l 1 + proc commandline_ls {args} { + set operands [list] + set posn 0 + foreach a $args { + if {![string match -* $a]} { + lappend operands $a + } else { + set flag1_posn $posn + break + } + incr posn + } + set args [lrange $args $flag1_posn end] + + + set debug 0 + set posn [lsearch $args -debug] + if {$posn > 0} { + if {[lindex $args $posn+1]} { + set debug [lindex $args $posn+1] + } + } + if {$debug} { + puts stderr "|debug>commandline_ls got $args" + } + + #if first operand not supplied - replace it with current working dir + if {[lindex $operands 0] eq "\uFFFF"} { + lset operands 0 [pwd] + } + + set targets [list] + foreach op $operands { + if {$op ne "\uFFFF"} { + set opchars [split [file tail $op] ""] + if {"?" in $opchars || "*" in $opchars} { + lappend targets $op + } else { + #actual file or dir + set targetitem $op + set targetitem [file normalize $op] + if {![file exists $targetitem]} { + if {$debug} { + puts stderr "|debug>commandline_ls Unable to access path '$targetitem'" + } + } + lappend targets $targetitem + if {$debug} { + puts stderr "|debug>commandline_ls listing for $targetitem" + } + } + } + } + set args [check_flags -caller commandline_ls \ + -return flagged|defaults \ + -debugargs 0 \ + -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 -algorithm sort] \ + -required {all} \ + -extras {all} \ + -soloflags {-v -l} \ + -commandprocessors {} \ + -values $args ] + if {$debug} { + puts stderr "|debug>args: $args" + } + + + set algorithm [dict get $args -algorithm] + dict unset args -algorithm + + set allfolders [list] + set allfiles [list] + foreach item $targets { + if {[file exists $item]} { + if {[file type $item] eq "directory"} { + set dotfolders [glob -nocomplain -directory $item -type {d} -tail .*] + set folders [glob -nocomplain -directory $item -type {d} -tail *] + set allfolders [concat $allfolders $dotfolders $folders] + + set dotfiles [glob -nocomplain -directory $item -type {f} -tail .*] + set files [glob -nocomplain -directory $item -type {f} -tail *] + set allfiles [concat $allfiles $dotfiles $files] + } else { + #file (or link?) + set files [glob -nocomplain -directory [file dirname $item] -tail [file tail $item]] + set allfiles [concat $allfiles $files] + } + } else { + set folders [glob -nocomplain -directory $item -type {d} -tail [file tail $item]] + set allfolders [concat $allfolders $folders] + set files [glob -nocomplain -directory [file dirname $item] -tail [file tail $item]] + set allfiles [concat $allfiles $files] + } + } + + + set sorted_folders [natsort::sort $allfolders {*}$args] + set sorted_files [natsort::sort $allfiles {*}$args] + + foreach fold $sorted_folders { + puts stdout $fold + } + foreach file $sorted_files { + puts stdout $file + } + + return "-- ok printed to stdout [llength $sorted_folders] folders and [llength $sorted_files] files --" + } + + package require argp + argp::registerArgs commandline_test { + { -showsplits boolean 0} + { -stacktrace boolean 0} + { -debug boolean 0} + { -winlike boolean 0} + { -db string ":memory:"} + { -collate string "nocase"} + { -algorithm string "sort"} + { -topchars string "\uFFFF"} + { -testlist string {10 1 30 3}} + } + argp::setArgsNeeded commandline_test {-stacktrace} + proc commandline_test {test args} { + variable testlist + puts stdout "commandline_test got $args" + argp::parseArgs opts + puts stdout "commandline_test got [array get opts]" + set args [check_flags -caller natsort_commandline \ + -return flagged|defaults \ + -defaults [list -db :memory: -collate nocase -testlist $testlist -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] \ + -values $args] + + if {[string tolower $test] in [list "1" "true"]} { + set test "sort" + } else { + if {![llength [info commands $test]]} { + error "test $test not found" + } + } + dict unset args -test + set stacktrace [dict get $args -stacktrace] + # dict unset args -stacktrace + + set argtestlist [dict get $args -testlist] + dict unset args -testlist + + + set debug [dict get $args -debug] + + set collate [dict get $args -collate] + set db [dict get $args -db] + set winlike [dict get $args -winlike] + set topchars [dict get $args -topchars] + + + puts stderr "|test>-----start natsort::$test--- input list size : [llength $argtestlist]" + #set resultlist [$test $argtestlist -db $db -collate $collate -topchars $topchars -winlike $winlike] + set resultlist [$test $argtestlist {*}$args] + foreach nm $resultlist { + puts stdout $nm + } + puts stdout "|test>-----end natsort::$test--- sorted list size: [llength $resultlist]" + return "test end" + } + proc commandline_runtests {runtests args} { + set argvals [check_flags -caller commandline_runtests \ + -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits "\uFFFF" -runtests 1] \ + -values $args] + + puts stderr "runtests args: $argvals" + + #set runtests [dict get $argvals -runtests] + dict unset argvals -runtests + dict unset argvals -algorithm + + puts stderr "runtests args: $argvals" + #exit 0 + + set test_prefix "::natsort::test_sort_" + + if {$runtests eq "1"} { + set runtests "*" + } + + + set testcommands [info commands ${test_prefix}${runtests}] + if {![llength $testcommands]} { + puts stderr "No test commands matched -runtests argument '$runtests'" + puts stderr "Use 1 to run all tests" + set alltests [info commands ${test_prefix}*] + puts stderr "Valid tests are:" + + set prefixlen [string length $test_prefix] + foreach t $alltests { + set shortname [string range $t $prefixlen end] + puts stderr "$t = -runtests $shortname" + } + + } else { + foreach cmd $testcommands { + puts stderr [string repeat - 40] + puts stderr "calling $cmd with args: '$argvals'" + puts stderr [string repeat - 40] + $cmd {*}$argvals + } + } + exit 0 + } + proc help {args} { + puts stdout "natsort::help got '$args'" + return "Help not implemented" + } + proc natsort_pipe {args} { + #PIPELINE to take input list on stdin and write sorted list to stdout + #strip - from arglist + #set args [check_flags -caller natsort_pipeline \ + # -return all \ + # -defaults [list -db :memory: -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] \ + # -values $args] + + + set debug [dict get $args -debug] + if {$debug} { + puts stderr "|debug> natsort_pipe got args:'$args'" + } + set algorithm [dict get $args -algorithm] + dict unset args -algorithm + + set proclist [info commands ::natsort::sort*] + set algos [list] + foreach p $proclist { + lappend algos [namespace tail $p] + } + if {$algorithm ni [list {*}$proclist {*}$algos]} { + do_error "valid sort mechanisms: $algos" 2 + } + + + set input_list [list] + while {![eof stdin]} { + if {[gets stdin line] > 0} { + lappend input_list $line + } else { + if {[eof stdin]} { + + } else { + after 10 + } + } + } + + if {$debug} { + puts stderr "|debug> received [llength $input_list] list elements" + } + + set resultlist [$algorithm $input_list {*}$args] + if {$debug} { + puts stderr "|debug> returning [llength $resultlist] list elements" + } + foreach r $resultlist { + puts stdout $r + } + #exit 0 + + } + if {($is_called_directly)} { + set cmdprocessors { + {helpfinal {match "^help$" dispatch natsort::help}} + {helpfinal {sub -topic default "NONE"}} + } + #set args [check_flags \ + # -caller test1 \ + # -debugargs 2 \ + # -return arglist \ + # -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] \ + # -required {none} \ + # -extras {all} \ + # -commandprocessors $cmdprocessors \ + # -values $::argv ] + interp alias {} do_filter {} ::flagfilter::check_flags + + #mashopts are generally single-letter opts that can be run together e.g -l -d as -ld + set cmdprocessors { + {helpcmd {match "^help$" dispatch natsort::help singleopts {-v}}} + {helpcmd {sub -operand default \uFFFF singleopts {-l}}} + {lscmd {match "^ls$" dispatch natsort::commandline_ls dispatchtype tcl dispatchglobal 1 mashopts {-l -a} singleopts {-l -a} pairopts {} longopts {--color=always}}} + {lscmd {sub dir default "\uFFFF"}} + {lscmd {sub dir2 default "\uFFFF"}} + {lscmd {sub dir3 default "\uFFFF"}} + {lscmd {sub dir4 default "\uFFFF"}} + {lscmd {sub dir5 default "\uFFFF"}} + {lscmd {sub dir6 default "\uFFFF"}} + {runtests {match "^-tests$" dispatch natsort::commandline_runtests singleopts {-l}}} + {runtests {sub testname default "1" singleopts {-l}}} + {pipecmd {match "^-$" dispatch natsort::natsort_pipe dispatchtype tcl}} + } + set arglist [do_filter \ + -debugargs 0 \ + -debugargsonerror 2 \ + -caller cline_dispatch1 \ + -return all \ + -soloflags {-v -x} \ + -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 ] \ + -required {all} \ + -extras {all} \ + -commandprocessors $cmdprocessors \ + -values $::argv ] + + + #mashopts are generally single-letter opts that can be run together e.g -l -d as -ld + set cmdprocessors { + {testcmd {match "^test$" dispatch natsort::commandline_test singleopts {-l}}} + {testcmd {sub testname default "1" singleopts {-l}}} + } + set arglist [check_flags \ + -debugargs 0 \ + -caller cline_dispatch2 \ + -return all \ + -soloflags {-v -l} \ + -defaults [list -collate nocase -algorithm sort -testlist "1 2 3 10" -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 ] \ + -required {all} \ + -extras {all} \ + -commandprocessors $cmdprocessors \ + -values $::argv ] + + + + + #set cmdprocessors [list] + #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors $cmdprocessors -values $::argv ] + + #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors {-cmd {-cmd -cmdarg1 -default "."} {-cmd -cmdarg2 -default j}} -values $::argv ] + #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors {{-cmd -default help} {-cmd -cmdarg1 -default "."} {-cmd -cmdarg2 -default j}} -values $::argv ] + #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors {ls {ls lsdir -default "\uFFFF"}} -values $::argv ] + + exit 0 + + if {$::argc} { + + } + } +} + + +package provide natsort [namespace eval natsort { + variable version + set version 0.1.1.5 +}] + + diff --git a/src/bootsupport/modules/oolib-0.1.tm b/src/bootsupport/modules/oolib-0.1.tm new file mode 100644 index 00000000..9cf1ca07 --- /dev/null +++ b/src/bootsupport/modules/oolib-0.1.tm @@ -0,0 +1,195 @@ +#JMN - api should be kept in sync with package patternlib where possible +# +package provide oolib [namespace eval oolib { + variable version + set version 0.1 +}] + +namespace eval oolib { + oo::class create collection { + variable o_data ;#dict + variable o_alias + constructor {} { + set o_data [dict create] + } + method info {} { + return [dict info $o_data] + } + method count {} { + return [dict size $o_data] + } + method isEmpty {} { + expr {[dict size $o_data] == 0} + } + method names {{globOrIdx {}}} { + if {[llength $globOrIdx]} { + if {[string is integer -strict $globOrIdx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + if {[catch {lindex [dict keys $o_data] $idx} result]} { + error "[self object] no such index : '$idx'" + } else { + return $result + } + } else { + #glob + return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] + } + } else { + return [dict keys $o_data] + } + } + #like names but without globbing + method keys {} { + dict keys $o_data + } + method key {{posn 0}} { + if {$posn < 0} { + set posn "end-[expr {abs($posn + 1)}]" + } + if {[catch {lindex [dict keys $o_data] $posn} result]} { + error "[self object] no such index : '$posn'" + } else { + return $result + } + } + method hasKey {key} { + dict exists $o_data $key + } + method get {} { + return $o_data + } + method items {} { + return [dict values $o_data] + } + method item {key} { + if {[string is integer -strict $key]} { + if {$key > 0} { + set valposn [expr {(2*$key) +1}] + return [lindex $o_data $valposn] + } else { + set key "end-[expr {abs($key + 1)}]" + return [lindex [dict keys $o_data] $key] + } + } + if {[dict exists $o_data $key]} { + return [dict get $o_data $key] + } + } + #inverse lookup + method itemKeys {value} { + set value_indices [lsearch -all [dict values $o_data] $value] + set keylist [list] + foreach i $value_indices { + set idx [expr {(($i + 1) *2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } + method search {value args} { + set matches [lsearch {*}$args [dict values $o_data] $value] + if {"-inline" in $args} { + return $matches + } else { + set keylist [list] + foreach i $matches { + set idx [expr {(($i + 1) *2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } + } + #review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? + method alias {newAlias existingKeyOrAlias} { + if {[string is integer -strict $newAlias]} { + error "[self object] collection key alias cannot be integer" + } + if {[string length $existingKeyOrAlias]} { + set o_alias($newAlias) $existingKeyOrAlias + } else { + unset o_alias($newAlias) + } + } + method aliases {{key ""}} { + if {[string length $key]} { + set result [list] + foreach {n v} [array get o_alias] { + if {$v eq $key} { + lappend result $n $v + } + } + return $result + } else { + return [array get o_alias] + } + } + #if the supplied index is an alias, return the underlying key; else return the index supplied. + method realKey {idx} { + if {[catch {set o_alias($idx)} key]} { + return $idx + } else { + return $key + } + } + method add {value key} { + if {[string is integer -strict $key]} { + error "[self object] collection key must not be an integer. Use another structure if integer keys required" + } + if {[dict exists $o_data $key]} { + error "[self object] col_processors object error: key '$key' already exists in collection" + } + dict set o_data $key $value + return [expr {[dict size $o_data] - 1}] ;#return index of item + } + method remove {idx {endRange ""}} { + if {[string length $endRange]} { + error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" + } + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx+1)}]" + } + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + if {$posn < 0} { + error "[self object] no such index: '$idx' in this collection" + } + } + dict unset o_data $key + return + } + method clear {} { + set o_data [dict create] + return + } + method reverse {} { + set dictnew [dict create] + foreach k [lreverse [dict keys $o_data]] { + dict set dictnew $k [dict get $o_data $k] + } + set o_data $dictnew + return + } + #review - cmd as list vs cmd as script? + method map {cmd} { + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list {*}$cmd $v]] + } + return $seed + } + method objectmap {cmd} { + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list $v {*}$cmd]] + } + return $seed + } + } + +} + diff --git a/src/bootsupport/modules/overtype-1.5.0.tm b/src/bootsupport/modules/overtype-1.5.0.tm new file mode 100644 index 00000000..f4e466f3 --- /dev/null +++ b/src/bootsupport/modules/overtype-1.5.0.tm @@ -0,0 +1,1039 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) Julian Noble 2003-2023 +# +# @@ Meta Begin +# Application overtype 1.5.0 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz +package require textutil +package require punk::ansi ;#required to detect, split, strip and calculate lengths +package require punk::char ;#box drawing - and also unicode character width determination for proper layout of text with double-column-width chars + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#Julian Noble - 2003 +#Released under standard 'BSD license' conditions. +# +#todo - ellipsis truncation indicator for center,right + +#v1.4 2023-07 - naive ansi color handling - todo - fix string range +# - need to extract and replace ansi codes? + +namespace eval overtype { + namespace export * + variable default_ellipsis_horizontal "..." ;#fallback + variable default_ellipsis_vertical "..." + namespace eval priv { + proc _init {} { + upvar ::overtype::default_ellipsis_horizontal e_h + upvar ::overtype::default_ellipsis_vertical e_v + set e_h [format %c 0x2026] ;#Unicode Horizontal Ellipsis + set e_v [format %c 0x22EE] + #The unicode ellipsis looks more natural than triple-dash which is centred vertically whereas ellipsis is at floorline of text + #Also - unicode ellipsis has semantic meaning that other processors can interpret + #unicode does also provide a midline horizontal ellipsis 0x22EF + + #set e [format %c 0x2504] ;#punk::char::charshort boxd_ltdshhz - Box Drawings Light Triple Dash Horizontal + #if {![catch {package require punk::char}]} { + # set e [punk::char::charshort boxd_ltdshhz] + #} + } + } + priv::_init +} +proc overtype::about {} { + return "Simple text formatting. Author JMN. BSD-License" +} + +namespace eval overtype { + variable escape_terminals + #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). + dict set escape_terminals CSI [list @ \\ ^ _ ` | ~ a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z "\{" "\}"] + #dict set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic + dict set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals + + #self-contained 2 byte ansi escape sequences - review more? + variable ansi_2byte_codes_dict + set ansi_2byte_codes_dict [dict create\ + "reset_terminal" "\u001bc"\ + "save_cursor_posn" "\u001b7"\ + "restore_cursor_posn" "\u001b8"\ + "cursor_up_one" "\u001bM"\ + "NEL - Next Line" "\u001bE"\ + "IND - Down one line" "\u001bD"\ + "HTS - Set Tab Stop" "\u001bH"\ + ] + + #debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway. + # "PM - Privacy Message" "\u001b^somethinghidden\033\\"\ +} + + +#candidate for zig/c implementation? +proc overtype::stripansi {text} { + variable escape_terminals ;#dict + variable ansi_2byte_codes_dict + #important that we don't spend too much time on this for plain text that doesn't contain any escapes anyway + if {[string first \033 $text] <0 && [string first \009c $text] <0} { + #\033 same as \x1b + return $text + } + + set text [convert_g0 $text] + + #we process char by char - line-endings whether \r\n or \n should be processed as per any other character. + #line endings can theoretically occur within an ansi escape sequence (review e.g title?) + set inputlist [split $text ""] + set outputlist [list] + + set 2bytecodes [dict values $ansi_2byte_codes_dict] + + set in_escapesequence 0 + #assumption - undertext already 'rendered' - ie no backspaces or carriagereturns or other cursor movement controls + set i 0 + foreach u $inputlist { + set v [lindex $inputlist $i+1] + set uv ${u}${v} + if {$in_escapesequence eq "2b"} { + #2nd byte - done. + set in_escapesequence 0 + } elseif {$in_escapesequence != 0} { + set escseq [dict get $escape_terminals $in_escapesequence] + if {$u in $escseq} { + set in_escapesequence 0 + } elseif {$uv in $escseq} { + set in_escapseequence 2b ;#flag next byte as last in sequence + } + } else { + #handle both 7-bit and 8-bit CSI and OSC + if {[regexp {^(?:\033\[|\u009b)} $uv]} { + set in_escapesequence CSI + } elseif {[regexp {^(?:\033\]|\u009c)} $uv]} { + set in_escapesequence OSC + } elseif {$uv in $2bytecodes} { + #self-contained e.g terminal reset - don't pass through. + set in_escapesequence 2b + } else { + lappend outputlist $u + } + } + incr i + } + return [join $outputlist ""] +} + +#review +#todo - map other chars to unicode equivs +proc overtype::convert_g0 {text} { + #using not \033 inside to stop greediness - review how does it compare to ".*?" + set re {\033\(0[^\033]*\033\(B} + set re2 {\033\(0(.*)\033\(B} ;#capturing + set parts [ta::_perlish_split $re $text] + set out "" + foreach {pt g} $parts { + append out $pt + if {$g ne ""} { + #puts --$g-- + #box sample + #lqk + #x x + #mqj + #m = boxd_lur + #set map [list l \u250f k \u2513] ;#heavy + set map [list l \u250c q \u2500 k \u2510 x \u2502 m \u2514 j \u2518] ;#light + + regexp $re2 $g _match contents + append out [string map $map $contents] + } + } + return $out +} + +#todo - convert esc(0 graphics sequences to single char unicode equivalents e.g box drawing set +# esc) ?? +proc overtype::stripansi_gx {text} { + #e.g "\033(0" - select VT100 graphics for character set G0 + #e.g "\033(B" - reset + #e.g "\033)0" - select VT100 graphics for character set G1 + #e.g "\033)X" - where X is any char other than 0 to reset ?? + return [convert_g0 $text] +} + + +#This shouldn't be called on text containing ansi codes! +proc overtype::strip_nonprinting_ascii {str} { + #review - some single-byte 'control' chars have visual representations e.g ETX as heart + #It is currently used for screen display width calculations + #equivalent for various unicode combining chars etc? + set map [list\ + \007 ""\ + [format %c 0] ""\ + [format %c 0x7f] ""\ + ] + return [string map $map $str] +} + +#length of text for printing characters only +#review - unicode and other non-printing chars and combining sequences? +#certain unicode chars are full-width (single char 2 columns wide) e.g see "Halfwdith and fullwidth forms" and ascii_fuillwidth blocks in punk::char::charset_names +#review - is there an existing library or better method? print to a terminal and query cursor position? +#Note this length calculation is only suitable for lines being appended to other strings if the line is pre-processed to account for backspace and carriage returns first +#If the raw line is appended to another string without such processing - the backspaces & carriage returns can affect data prior to the start of the string. +proc overtype::printing_length {line} { + if {[string first \n $line] >= 0} { + error "line_print_length must not contain newline characters" + } + + #review - + set line [stripansi $line] + + set line [strip_nonprinting_ascii $line] ;#only strip nonprinting after stripansi - some like BEL are part of ansi + #backspace 0x08 only erases* printing characters anyway - so presumably order of processing doesn't matter + #(* more correctly - moves cursor back) + #backspace will not move beyond a preceding newline - but we have disallowed newlines for this function already + #leading backspaces will eat into any string (even prompt in non-standard tclsh shell) that is prepended to the line + # - but for the purposes of overtype we wouldn't want that - so we strip it here in the length calculation and should strip leading backspaces in the actual data concatenation operations too. + #curiously - a backspace sequence at the end of a string also doesn't reduce the printing width - so we can also strip from RHS + + #Note that backspace following a \t will only shorten the string by one (ie it doesn't move back the whole tab width like it does interactively in the terminal) + #for this reason - it would seem best to normalize the tabs to spaces prior to performing the backspace calculation - otherwise we won't account for the 'short' tabs it effectivley produces + #normalize tabs to an appropriate* width + #*todo - handle terminal/context where tabwidth != the default 8 spaces + set line [textutil::tabify::untabify2 $line] + + set bs [format %c 0x08] + #set line [string map [list "\r${bs}" "\r"] $line] ;#backsp following a \r will have no effect + set line [string trim $line $bs] + set n 0 + + set chars [split $line ""] + #build an output + set idx 0 + set outchars [list] + set outsizes [list] + foreach c $chars { + if {$c eq $bs} { + if {$idx > 0} { + incr idx -1 + } + } elseif {$c eq "\r"} { + set idx 0 + } else { + priv::printing_length_addchar $idx $c + incr idx + } + } + set line2 [join $outchars ""] + return [punk::char::string_width $line2] +} + +proc overtype::string_columns {text} { + if {[punk::ansi::ta::detect $text]} { + error "error string_columns is for calculating character length of string - ansi codes must be stripped/rendered first e.g with overtype::stripansi. Alternatively try overtype::printing_length" + } + return [punk::char::string_width $text] +} + +namespace eval overtype::priv { + proc printing_length_addchar {i c} { + upvar outchars outc + upvar outsizes outs + set nxt [llength $outc] + if {$i < $nxt} { + lset outc $i $c + } else { + lappend outc $c + } + } +} + +#string range should generally be avoided for both undertext and overtext which contain ansi escapes and other cursor affecting chars such as \b and \r +proc overtype::left {args} { + # @c overtype starting at left (overstrike) + # @c can/should we use something like this?: 'format "%-*s" $len $overtext + variable default_ellipsis_horizontal + + if {[llength $args] < 2} { + error {usage: ?-transparent [0|1]? ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} + } + lassign [lrange $args end-1 end] underblock overblock + set defaults [dict create\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -overflow 0\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + ] + set known_opts [dict keys $defaults] + set argsflags [lrange $args 0 end-2] + dict for {k v} $argsflags { + if {$k ni $known_opts} { + error "overtype::left unknown option '$k'. Known options: $known_opts" + } + } + set opts [dict merge $defaults $argsflags] + # -- --- --- --- --- --- + set opt_transparent [dict get $opts -transparent] + set opt_ellipsistext [dict get $opts -ellipsistext] + set opt_exposed1 [dict get $opts -exposed1] + set opt_exposed2 [dict get $opts -exposed2] + # -- --- --- --- --- --- + + set norm [list \r\n \n] + set underblock [string map $norm $underblock] + set overblock [string map $norm $overblock] + + set underlines [split $underblock \n] + set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {printing_length $v}]] + set overlines [split $overblock \n] + + set outputlines [list] + foreach undertext $underlines overtext $overlines { + set undertext_printlen [printing_length $undertext] + set overlen [printing_length $overtext] + set diff [expr {$overlen - $colwidth}] + + #review + #append overtext "\033\[0m" + + if {$diff > 0} { + #background line is narrower + set rendered [renderline -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow [dict get $opts -overflow] $undertext $overtext] + if {![dict get $opts -overflow]} { + #set overtext [string range $overtext 0 $colwidth-1] ;#string range won't be correct e.g if contains ansi codes or leading \r or \b etc + if {[dict get $opts -ellipsis]} { + set rendered [overtype::right $rendered $opt_ellipsistext] + } + } + lappend outputlines $rendered + } else { + #we know overtext is shorter or equal + lappend outputlines [renderline -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + } + } + return [join $outputlines \n] + +} + +namespace eval overtype::piper { + proc overcentre {args} { + if {[llength $args] < 2} { + error {usage: ?-bias left|right? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} + } + lassign [lrange $args end-1 end] over under + set argsflags [lrange $args 0 end-2] + tailcall overtype::centre {*}$argsflags $under $over + } + proc overleft {args} { + if {[llength $args] < 2} { + error {usage: ?-start ? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} + } + lassign [lrange $args end-1 end] over under + set argsflags [lrange $args 0 end-2] + tailcall overtype::left {*}$argsflags $under $over + } +} +#todo - left-right ellipsis ? +proc overtype::centre {args} { + variable default_ellipsis_horizontal + if {[llength $args] < 2} { + error {usage: ?-transparent [0|1]? ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} + } + + foreach {underblock overblock} [lrange $args end-1 end] break + + set defaults [dict create\ + -bias left\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -overflow 0\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + ] + set known_opts [dict keys $defaults] + set argsflags [lrange $args 0 end-2] + dict for {k v} $argsflags { + if {$k ni $known_opts} { + error "overtype::centre unknown option '$k'. Known options: $known_opts" + } + } + set opts [dict merge $defaults $argsflags] + # -- --- --- --- --- --- + set opt_transparent [dict get $opts -transparent] + set opt_ellipsistext [dict get $opts -ellipsistext] + set opt_exposed1 [dict get $opts -exposed1] + set opt_exposed2 [dict get $opts -exposed2] + # -- --- --- --- --- --- + + + set norm [list \r\n \n] + set underblock [string map $norm $underblock] + set overblock [string map $norm $overblock] + + set underlines [split $underblock \n] + set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {printing_length $v}]] + set overlines [split $overblock \n] + + set outputlines [list] + foreach undertext $underlines overtext $overlines { + set olen [printing_length $overtext] + set ulen [printing_length $undertext] + if {$ulen < $colwidth} { + set udiff [expr {$colwidth - $ulen}] + set undertext "$undertext[string repeat { } $udiff]" + } + #review + append overtext "\033\[0m" + + set diff [expr {$colwidth - $olen}] + if {$diff > 0} { + #background block is wider + set half [expr {round(int($diff / 2))}] + if {[string match right [dict get $opts -bias]]} { + if {[expr {2 * $half}] < $diff} { + incr half + } + } + + set rhs [expr {$diff - $half - 1}] + set lhs [expr {$half - 1}] + set rhsoffset [expr {$rhs +1}] + if 0 { + set a [string range $undertext 0 $lhs] + set background [string range $undertext $lhs+1 end-$rhsoffset] + set b [renderline -transparent $opt_transparent $background $overtext] + set c [string range $undertext end-$rhs end] + lappend outputlines $a$b$c + } + lappend outputlines [renderline -start $lhs -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + + } else { + #overlay wider or equal + set rendered [renderline -transparent $opt_transparent -overflow [dict get $opts -overflow] $undertext $overtext] + if {$diff < 0} { + #overlay is wider - trim if overflow not specified in opts + if {![dict get $opts -overflow]} { + #lappend outputlines [string range $overtext 0 [expr {$colwidth - 1}]] + #set overtext [string range $overtext 0 $colwidth-1 ] + if {[dict get $opts -ellipsis]} { + set rendered [overtype::right $rendered $opt_ellipsistext] + } + } + } else { + #widths match + } + lappend outputlines $rendered + #lappend outputlines [renderline -transparent $opt_transparent $undertext $overtext] + } + } + return [join $outputlines \n] +} + +proc overtype::right {args} { + variable default_ellipsis_horizontal + # @d !todo - implement overflow, length checks etc + + if {[llength $args] < 2} { + error {usage: ?-overflow [1|0]? undertext overtext} + } + foreach {underblock overblock} [lrange $args end-1 end] break + + set defaults [dict create\ + -bias left\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -overflow 0\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + ] + set known_opts [dict keys $defaults] + set argsflags [lrange $args 0 end-2] + dict for {k v} $argsflags { + if {$k ni $known_opts} { + error "overtype::centre unknown option '$k'. Known options: $known_opts" + } + } + set opts [dict merge $defaults $argsflags] + # -- --- --- --- --- --- + set opt_transparent [dict get $opts -transparent] + set opt_ellipsis [dict get $opts -ellipsis] + set opt_ellipsistext [dict get $opts -ellipsistext] + set opt_overflow [dict get $opts -overflow] + set opt_exposed1 [dict get $opts -exposed1] + set opt_exposed2 [dict get $opts -exposed2] + # -- --- --- --- --- --- + + set norm [list \r\n \n] + set underblock [string map $norm $underblock] + set overblock [string map $norm $overblock] + + set underlines [split $underblock \n] + set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {printing_length $v}]] + set overlines [split $overblock \n] + + set outputlines [list] + foreach undertext $underlines overtext $overlines { + set olen [printing_length $overtext] + set ulen [printing_length $undertext] + if {$ulen < $colwidth} { + set udiff [expr {$colwidth - $ulen}] + set undertext "$undertext[string repeat { } $udiff]" + } + #review + #append overtext "\033\[0m" + + set overflowlength [expr {$olen - $colwidth}] + if {$overflowlength > 0} { + #overtext wider than undertext column + set rendered [renderline -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow $opt_overflow -start 0 $undertext $overtext] + if {!$opt_overflow} { + if {$opt_ellipsis} { + set rendered [overtype::right $rendered $opt_ellipsistext] + } + } + lappend outputlines $rendered + } else { + #lappend outputlines [string range $undertext 0 end-$olen]$overtext + lappend outputlines [renderline -transparent $opt_transparent -start [expr {$colwidth - $olen}] $undertext $overtext] + } + } + + return [join $outputlines \n] +} + +# -- --- --- --- --- --- --- --- --- --- --- +proc overtype::transparentline {args} { + foreach {under over} [lrange $args end-1 end] break + set argsflags [lrange $args 0 end-2] + set defaults [dict create\ + -transparent 1\ + -exposed 1 " "\ + -exposed 2 " "\ + ] + set newargs [dict merge $defaults $argsflags] + tailcall overtype::renderline {*}$newargs $under $over +} +#renderline may not make sense as it is in the long run for blocks of text - but is handy in the single-line-handling form anyway. +# We are trying to handle ansi codes in a block of text which is acting like a mini-terminal in some sense. +#We can process standard cursor moves such as \b \r - but no way to respond to other cursor movements e.g moving to other lines. +# +namespace eval overtype::piper { + proc renderline {args} { + if {[llength $args] < 2} { + error {usage: ?-start ? ?-transparent [0|1|]? ?-overflow [1|0]? overtext pipelinedata} + } + foreach {over under} [lrange $args end-1 end] break + set argsflags [lrange $args 0 end-2] + tailcall overtype::renderline {*}$argsflags $under $over + } +} +interp alias "" piper_renderline "" overtype::piper::renderline + +#-returnextra to enable returning of overflow and length +# todo - use ta::detect to short-circuit processing and do simple string calcs as an optimisation? +#review - DECSWL/DECDWL double width line codes - very difficult/impossible to align and compose with other elements +#todo - review transparency issues with single/double width characters! +proc overtype::renderline {args} { + if {[llength $args] < 2} { + error {usage: ?-start ? ?-transparent [0|1|]? ?-overflow [1|0]? undertext overtext} + } + lassign [lrange $args end-1 end] under over + if {[string first \n $under] >=0 || [string first \n $over] >= 0} { + error "overtype::renderline not allowed to contain newlines" + } + set defaults [dict create\ + -overflow 0\ + -transparent 0\ + -start 0\ + -returnextra 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + ] + #exposed1 and exposed2 for first and second col of underying 2wide char which is truncated by transparency or overflow + + set known_opts [dict keys $defaults] + set argsflags [lrange $args 0 end-2] + dict for {k v} $argsflags { + if {$k ni $known_opts} { + error "overtype::renderline unknown option '$k'. Known options: $known_opts" + } + } + set opts [dict merge $defaults $argsflags] + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_overflow [dict get $opts -overflow] + set opt_colstart [dict get $opts -start] + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_transparent [dict get $opts -transparent] + if {$opt_transparent eq "0"} { + set do_transparency 0 + } else { + set do_transparency 1 + if {$opt_transparent eq "1"} { + set opt_transparent {[\s]} + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_returnextra [dict get $opts -returnextra] + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_exposed1 [dict get $opts -exposed1] + set opt_exposed2 [dict get $opts -exposed2] + # -- --- --- --- --- --- --- --- --- --- --- --- + + #----- + # + if {[string first \t $under] >= 0} { + #set under [textutil::tabify::untabify2 $under] + set under [textutil::tabify::untabifyLine $under 8] ;#8 is default for untabify2 - review + } + set overdata $over + if {[string first \t $over] >= 0} { + #set overdata [textutil::tabify::untabify2 $over] + set overdata [textutil::tabify::untabifyLine $over 8] + } + #------- + + #ta_detect ansi and do simpler processing? + + + # -- --- --- --- --- --- --- --- + set undermap [punk::ansi::ta::split_codes_single $under] + set understacks [dict create] + + set i_u -1 + set i_o 0 + set out [list] + set u_codestack [list] + set pt_underchars "" ;#for string_columns length calculation for overflow 0 truncation + set remainder [list] ;#for returnextra + foreach {pt code} $undermap { + #pt = plain text + append pt_underchars $pt + foreach ch [split $pt ""] { + set width [punk::char::string_width $ch] + incr i_u + dict set understacks $i_u $u_codestack + lappend out $ch + if {$width > 1} { + #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) + incr i_u + dict set understacks $i_u $u_codestack + lappend out "" + } + } + #underlay should already have been rendered and not have non-sgr codes - but let's check for and not stack them if other codes are here + if {[priv::is_sgr $code]} { + if {[priv::has_sgr_leadingreset $code]} { + set u_codestack [list $code] + } else { + lappend u_codestack $code + } + } + #consider also other codes that should be stacked..? + } + #trailing codes in effect for underlay + if {[llength $undermap]} { + dict set understacks [expr {$i_u + 1}] $u_codestack + } + + + # -- --- --- --- --- --- --- --- + #### + #if opt_colstart - we need to build a space (or any singlewidth char really) padding on the left of the right number of columns. + #this will be processed as transparent - and handle doublewidth underlay characters appropriately + set startpad [string repeat " " $opt_colstart] + append startpad $overdata ;#overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency + set overmap [punk::ansi::ta::split_codes_single $startpad] + #### + + + + set overstacks [dict create] + set o_codestack [list] + set pt_overchars "" + foreach {pt code} $overmap { + append pt_overchars $pt + foreach ch [split $pt ""] { + dict set overstacks $i_o $o_codestack + incr i_o + } + if {[priv::is_sgr $code]} { + #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc + if {[priv::has_sgr_leadingreset $code]} { + #m code which has sgr reset at start - no need to replay prior sgr codes + set o_codestack [list $code] + } else { + lappend o_codestack $code + } + } + } + # -- --- --- --- --- --- --- --- + + + + + set bs [format %c 0x08] + set idx 0 ;# line index (cursor - 1) + set idx_over -1 + foreach {pt code} $overmap { + set ptchars [split $pt ""] ;#for lookahead + #emit plaintext chars first using existing SGR codes from under/over stack as appropriate + #then check if the following code is a cursor movement within the line and adjust index if so + foreach ch $ptchars { + incr idx_over + if {$ch eq "\r"} { + set idx $opt_colstart + } elseif {$ch eq "\b"} { + #review - backspace effect on double-width chars + if {$idx > $opt_colstart} { + incr idx -1 + } + } elseif {($idx < $opt_colstart)} { + incr idx + } elseif {($do_transparency && [regexp $opt_transparent $ch])} { + #pre opt_colstart is effectively transparent (we have applied padding of required number of columns to left of overlay) + set owidth [punk::char::string_width $ch] + if {$idx > [llength $out]-1} { + lappend out " " + dict set understacks $idx [list] ;#review - use idx-1 codestack? + incr idx + } else { + set uwidth [punk::char::string_width [lindex $out $idx]] + if {[lindex $out $idx] eq ""} { + #2nd col of 2-wide char in underlay + incr idx + } elseif {$uwidth == 0} { + #e.g combining diacritic + incr idx + } elseif {$uwidth == 1} { + incr idx + if {$owidth > 1} { + incr idx + } + } elseif {$uwidth > 1} { + if {[punk::char::string_width $ch] == 1} { + #normal singlewide transparency + set next_pt_overchar [string index $pt_overchars $idx_over+1] ;#lookahead of next plain-text char in overlay + if {$next_pt_overchar eq ""} { + #special-case trailing transparent - no next_pt_overchar + incr idx + } else { + if {[regexp $opt_transparent $next_pt_overchar]} { + incr idx + } else { + #next overlay char is not transparent.. first-half of underlying 2wide char is exposed + priv::render_addchar $idx $opt_exposed1 [dict get $overstacks $idx_over] + incr idx + } + } + } else { + #2wide transparency over 2wide in underlay + incr idx + } + } + } + } else { + #non-transparent char in overlay + set owidth [punk::char::string_width $ch] + set uwidth [punk::char::string_width [lindex $out $idx]] + if {[lindex $out $idx] eq ""} { + #2nd col of 2wide char in underlay + priv::render_addchar $idx $ch [dict get $overstacks $idx_over] + incr idx + } elseif {$uwidth == 0} { + #e.g combining diacritic - increment before over char REVIEW + #arguably the previous overchar should have done this - ie lookahead for combiners? + priv::render_addchar $idx "" [dict get $overstacks $idx_over] + incr idx + priv::render_addchar $idx $ch [dict get $overstacks $idx_over] + incr idx + + } elseif {$uwidth == 1} { + if {$owidth == 1} { + priv::render_addchar $idx $ch [dict get $overstacks $idx_over] + incr idx + } else { + priv::render_addchar $idx $ch [dict get $overstacks $idx_over] + incr idx + priv::render_addchar $idx "" [dict get $overstacks $idx_over] + } + } elseif {$uwidth > 1} { + if {$owidth == 1} { + priv::render_addchar $idx $ch [dict get $overstacks $idx_over] + incr idx + priv::render_addchar $idx $opt_exposed2 [dict get $overstacks $idx_over] + #don't incr idx - we are just putting a broken-indication in the underlay - which may get overwritten by next overlay char + } else { + #2wide over 2wide + priv::render_addchar $idx $ch [dict get $overstacks $idx_over] + incr idx + } + } + } + } + #check following code + if {![priv::is_sgr $code]} { + + } + } + + if {$opt_overflow == 0} { + #need to truncate to the width of the original undertext + #review - string_width vs printing_length here. undertext requirement to be already rendered therefore punk::char::string_width ok? + set num_under_columns [punk::char::string_width $pt_underchars] ;#plaintext underchars + } + + #coalesce and replay codestacks for out char list + set outstring "" + set remstring "" ;#remainder after overflow point reached + set i 0 + set cstack [list] + set prevstack [list] + set out_rawchars ""; #for overflow counting + set output_to "outstring" ;#var in effect depending on overflow + set in_overflow 0 ;#used to stop char-width scanning once in overflow + foreach ch $out { + append out_rawchars $ch + if {$opt_overflow == 0 && !$in_overflow} { + if {[set nextvisualwidth [punk::char::string_width $out_rawchars]] < $num_under_columns} { + } else { + #todo - check if we overflowed with a double-width char ? + #store visualwidth which may be short + set in_overflow 1 + } + } + set cstack [dict get $understacks $i] + if {$cstack ne $prevstack} { + if {[llength $prevstack]} { + append $output_to \033\[m + } + foreach code $cstack { + append $output_to $code + } + } + append $output_to $ch + set prevstack $cstack + incr i + if {$in_overflow} { + set output_to "remstring" + } + } + if {[dict size $understacks] > 0} { + append $output_to [join [dict get $understacks [expr {[dict size $understacks]-1}]] ""] ;#tail codes + } + if {[string length $remstring]} { + #puts stderr "remainder:$remstring" + } + #pdict $understacks + if {$opt_returnextra} { + return [list $outstring $visualwidth [string length $outstring] $remstring] + } else { + return $outstring + } + #return [join $out ""] +} +proc overtype::test_renderline {} { + set t \uFF5E ;#2-wide tilde + set u \uFF3F ;#2-wide underscore + set missing \uFFFD + return [list $t $u A${t}B] +} +namespace eval overtype::priv { + #todo - move to punk::ansi::codetype + proc is_sgr {code} { + #SGR (Select Graphic Rendition) - codes ending in 'm' - e.g colour/underline + #we will accept and pass through the less common colon separator (ITU Open Document Architecture) + #Terminals should generally ignore it if they don't use it + regexp {\033\[[0-9;:]*m$} $code + } + proc is_cursor_move_in_line {code} { + #review - what about CSI n : m H where row n happens to be current line? + regexp {\033\[[0-9]*(:?C|D|G)$} + } + #pure SGR reset + proc is_sgr_reset {code} { + #todo 8-bit csi + regexp {\033\[0*m$} $code + } + #whether this code has 0 (or equivalently empty) parameter (but may set others) + #if an SGR code as a reset in it - we don't need to carry forward any previous SGR codes + #it generally only makes sense for the reset to be the first entry - otherwise the code has ineffective portions + #However - detecting zero or empty parameter in other positions requires knowing all other codes that may allow zero or empty params. + #We will only look at initial parameter as this is the well-formed normal case. + #Review - consider normalizing sgr codes to remove other redundancies such as setting fg or bg color twice in same code + proc has_sgr_leadingreset {code} { + set params "" + regexp {\033\[(.*)m} $code _match params + set plist [split $params ";"] + if {[string trim [lindex $plist 0] 0] eq ""} { + #e.g \033\[m \033\[0\;...m \033\[0000...m + return 1 + } else { + return 0 + } + } + #has_sgr_reset - rather than support this - create an sgr normalize function that removes dead params and brings reset to front of param list + proc render_addchar {i c stack} { + upvar out o + upvar understacks ustacks + set nxt [llength $o] + if {$i < $nxt} { + lset o $i $c + } else { + lappend o $c + } + dict set ustacks $i $stack + } + +} + + +# -- --- --- --- --- --- --- --- --- --- --- +namespace eval overtype::ta { + namespace path ::overtype + #*based* on but not identical to: + #https://github.com/perlancar/perl-Text-ANSI-Util/blob/master/lib/Text/ANSI/BaseUtil.pm + + #handle both 7-bit and 8-bit csi + #review - does codepage affect this? e.g ebcdic has 8bit csi in different position + + #CSI + #variable re_csi_open {(?:\033\[|\u009b)[0-9;]+} ;#too specific - doesn't detect \033\[m + variable re_csi_open {(?:\033\[|\u009b])} + + #colour and style + variable re_csi_colour {(?:\033\[|\u009b)[0-9;]*m} ;#e.g \033\[31m \033\[m \033\[0m \033\[m0000m + #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). + variable re_csi_code {(?:\033\[|\u009b])[0-9;]*[a-zA-Z\\@^_|~`]} + + #OSC - termnate with BEL (\a \007) or ST (string terminator \033\\) + #variable re_esc_osc1 {(?:\033\]|\u009c).*\007} + #variable re_esc_osc2 {(?:\033\]|\u009c).*\033\\} + + #test - non-greedy + variable re_esc_osc1 {(?:\033\]|\u009c).*?\007} + variable re_esc_osc2 {(?:\033\]|\u009c).*?\033\\} + + variable re_ansi_detect "${re_csi_open}|${re_esc_osc1}|${re_esc_osc2}" + + #detect any ansi escapes + #review - only detect 'complete' codes - or just use the opening escapes for performance? + proc detect {text} { + variable re_ansi_detect + #variable re_csi_open + #variable re_esc_osc1 + #variable re_esc_osc2 + #todo - other escape sequences + #expr {[regexp $re_csi_open $text] || [regexp $re_esc_osc1 $text] || [regexp $re_esc_osc2 $text]} + expr {[regexp $re_ansi_detect $text]} + } + #not in perl ta + proc detect_csi {text} { + variable re_csi_colour + expr {[regexp $re_csi_colour $text]} + } + proc strip {text} { + tailcall stripansi $text + } + #note this is character length after stripping ansi codes - not the printing length + proc length {text} { + string length [overtype::stripansi $text] + } + #todo - handle newlines + #not in perl ta + proc printing_length {text} { + + } + + proc trunc {text width args} { + + } + + #not in perl ta + #returns just the plaintext portions in a list + proc split_at_codes {text} { + variable re_esc_osc1 + variable re_esc_osc2 + variable re_csi_code + textutil::splitx $text "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}" + } + + # -- --- --- --- --- --- + #Split $text to a list containing alternating ANSI color codes and text. + #ANSI color codes are always on the second element, fourth, and so on. + #(ie plaintext on odd list-indices ansi on even indices) + # Example: + #ta_split_codes "" # => "" + #ta_split_codes "a" # => "a" + #ta_split_codes "a\e[31m" # => {"a" "\e[31m"} + #ta_split_codes "\e[31ma" # => {"" "\e[31m" "a"} + #ta_split_codes "\e[31ma\e[0m" # => {"" "\e[31m" "a" "\e[0m"} + #ta_split_codes "\e[31ma\e[0mb" # => {"" "\e[31m" "a" "\e[0m", "b"} + #ta_split_codes "\e[31m\e[0mb" # => {"" "\e[31m\e[0m" "b"} + # + proc split_codes {text} { + variable re_esc_osc1 + variable re_esc_osc2 + variable re_csi_code + set re "(?:${re_csi_code}|${re_esc_osc1}|${re_esc_osc2})+" + return [_perlish_split $re $text] + } + #like split_codes - but each ansi-escape is split out separately (with empty string of plaintext between codes so odd/even plain ansi still holds) + proc split_codes_single {text} { + variable re_esc_osc1 + variable re_esc_osc2 + variable re_csi_code + set re "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}" + return [_perlish_split $re $text] + } + + #review - tcl greedy expressions may match multiple in one element + proc _perlish_split {re text} { + if {[string length $text] == 0} { + return {} + } + set list [list] + set start 0 + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + lappend list [string range $text $start $matchStart-1] [string range $text $matchStart $matchEnd] + set start [expr {$matchEnd+1}] + } + lappend list [string range $text $start end] + return $list + } + proc _ws_split {text} { + regexp -all -inline {(?:\S+)|(?:\s+)} $text + } + # -- --- --- --- --- --- + +} + +# -- --- --- --- --- --- --- --- --- --- --- +namespace eval overtype { + interp alias {} ::overtype::center {} ::overtype::centre +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide overtype [namespace eval overtype { + variable version + set version 1.5.0 +}] +return \ No newline at end of file diff --git a/src/bootsupport/modules/punk/du-0.1.0.tm b/src/bootsupport/modules/punk/du-0.1.0.tm index 2296702c..ff7999fe 100644 --- a/src/bootsupport/modules/punk/du-0.1.0.tm +++ b/src/bootsupport/modules/punk/du-0.1.0.tm @@ -9,7 +9,7 @@ # @@ Meta Begin # Application punk::du 0.1.0 # Meta platform tcl -# Meta license +# Meta license BSD # @@ Meta End @@ -17,6 +17,8 @@ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Requirements ##e.g package require frobz +package require punk::mix::base + namespace eval punk::du { variable has_twapi 0 @@ -29,7 +31,7 @@ if {"windows" eq $::tcl_platform(platform)} { #} else { # set punk::du::has_twapi 1 #} - package require punk::winpath + #package require punk::winpath } @@ -37,7 +39,14 @@ if {"windows" eq $::tcl_platform(platform)} { namespace eval punk::du { - proc dirlisting {{folderpath {}}} { + proc dirlisting {folderpath args} { + set defaults [dict create\ + -glob *\ + ] + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_glob [dict get $opts -glob] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- if {[lib::pathcharacterlen $folderpath] == 0} { set folderpath [pwd] } elseif {[file pathtype $folderpath] ne "absolute"} { @@ -46,7 +55,7 @@ namespace eval punk::du { } #run whichever of du_dirlisting_twapi, du_dirlisting_generic, du_dirlisting_unix has been activated - set dirinfo [active::du_dirlisting $folderpath] + set dirinfo [active::du_dirlisting $folderpath {*}$opts] } @@ -151,6 +160,8 @@ namespace eval punk::du { set opt_extra 1 } set opt_vfs 0 + #This configures whether to enter a vfsmount point + #It will have no effect if cwd already with a vfs mount point - as then opt_vfs will be set to 1 automatically anyway. if {"--vfs" in $lc_opts} { set opt_vfs 1 } @@ -213,10 +224,18 @@ namespace eval punk::du { #e.g tcl glob based dirlisting doesn't support gathering file sizes at the same time set in_vfs 0 - if {$opt_vfs} { + if {[package provide vfs] ne ""} { foreach vfsmount [vfs::filesystem info] { - if {[punk::repo::path_a_atorbelow_b $folderpath $vfsmount]} { + if {[file pathtype $folderpath] ne "absolute"} { + set testpath [file normalize $folderpath] + } else { + set testpath $folderpath + } + + if {[punk::mix::base::lib::path_a_atorbelow_b $testpath $vfsmount]} { set in_vfs 1 + #if already descended to or below a vfs mount point - set opt_vfs true + set opt_vfs 1 break } } @@ -229,10 +248,30 @@ namespace eval punk::du { set du_info [active::du_dirlisting $folderpath] } - + set dirs [dict get $du_info dirs] set files [dict get $du_info files] set filesizes [dict get $du_info filesizes] + set vfsmounts [dict get $du_info vfsmounts] + #puts "---> vfsmounts $vfsmounts " + if {$opt_vfs} { + foreach vm $vfsmounts { + #puts stderr "vm: $vm" + #check if vfs is mounted over a file or a dir + if {$vm in $files} { + puts stderr "vfs mounted over file $vm" + set mposn [lsearch $files $vm] + set files [lreplace $files $mposn $mposn] + if {[llength $filesizes]} { + set filesizes [lreplace $filesizes $mposn $mposn] + } + } + if {$vm ni $dirs} { + puts stderr "treating $vm as dir" + lappend dirs $vm + } + } + } incr leveldirs [llength $dirs] @@ -361,7 +400,7 @@ namespace eval punk::du { variable functions_known [dict create] #known functions from lib namespace - dict set functions_known du_dirlisting [list du_dirlisting_twapi du_dirlisting_generic du_dirlisting_unix] + dict set functions_known du_dirlisting [list du_dirlisting_twapi du_dirlisting_generic du_dirlisting_unix du_dirlisting_undecided] proc show_functions {} { variable functions @@ -443,10 +482,11 @@ namespace eval punk::du { dict set result -shortname [dict get $iteminfo altname] dict set result -rawflags $attrinfo set extras [list] - foreach prop {ctime atime mtime size} { - lappend extras $prop [dict get $iteminfo $prop] - } - dict set result -extras $extras + #foreach prop {ctime atime mtime size} { + # lappend extras $prop [dict get $iteminfo $prop] + #} + #dict set result -extras $extras + dict set result -raw $iteminfo return $result } else { error "could not read attributes for $path" @@ -455,29 +495,101 @@ namespace eval punk::du { catch {twapi::find_file_close $iterator} } } - namespace export du_dirlisting_twapi du_dirlisting_generic du_dirlisting_unix + + #todo - review 'errors' key. We have errors relating to containing folder and args vs per child-item errors - additional key needed? + namespace export du_dirlisting_twapi du_dirlisting_generic du_dirlisting_unix du_dirlisting_undecided # get listing without using unix-tools (may not be installed on the windows system) # this dirlisting is customised for du - so only retrieves dirs,files,filesizes (minimum work needed to perform du function) - proc du_dirlisting_twapi {folderpath} { + # This also preserves path rep for elements in the dirs/folders keys etc - which can make a big difference in performance + proc du_dirlisting_twapi {folderpath args} { + set defaults [dict create\ + -glob *\ + -with_sizes 1\ + -with_times 1\ + ] + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_glob [dict get $opts -glob] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_with_sizes [dict get $opts -with_sizes] + set ftypes [list f d l] + if {"$opt_with_sizes" in {0 1}} { + #don't use string is boolean - (f false vs f file!) + #only accept 0|1 + if {$opt_with_sizes} { + set sized_types $ftypes + } else { + set sized_types [list] + } + } else { + set sized_types $opt_with_sizes + } + if {[llength $sized_types]} { + foreach st $sized_types { + if {$st ni $ftypes} { + error "du_dirlisting_twapi unrecognized element in -with_sizes '$st'" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_with_times [dict get $opts -with_times] + if {"$opt_with_times" in {0 1}} { + if {$opt_with_times} { + set timed_types $ftypes + } else { + set timed_types [list] + } + } else { + set timed_types $opt_with_times + } + if {[llength $timed_types]} { + foreach item $timed_types { + if {$item ni $ftypes} { + error "du_dirlisting_twapi unrecognised element in -with-times '$item'" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + + set errors [dict create] set altname "" ;#possible we have to use a different name e.g short windows name or dos-device path //?/ # return it so it can be stored and tried as an alternative for problem paths + #puts stderr ">>> glob: $opt_glob" + #REVIEW! windows api pattern matchttps://www.red-gate.com/simple-talk/blogs/the-unexpected-behaviour-of-directoryinfo-getfiles-with-three-letter-extensions/hing is .. weird. partly due to 8.3 filenames + #https://www.red-gate.com/simple-talk/blogs/the-unexpected-behaviour-of-directoryinfo-getfiles-with-three-letter-extensions/ + #we will certainly need to check the resulting listing with our supplied glob.. but maybe we will have to change the glob passed to find_file_open too. + # using * all the time may be inefficient - so we might be able to avoid that in some cases. try { - set iterator [twapi::find_file_open [file join $folderpath *] -detail basic] ;# -detail full only adds data to the altname field + #glob of * will return dotfiles too on windows + set iterator [twapi::find_file_open [file join $folderpath $opt_glob] -detail basic] ;# -detail full only adds data to the altname field } on error args { try { if {[string match "*denied*" $args]} { #output similar format as unixy du puts stderr "[file dirname $folderpath] '[file tail $folderpath]':$args" - return [list dirs {} vfsmounts {} links {} files {} filesizes {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {}] + dict lappend errors $folderpath $::errorCode + return [list dirs {} vfsmounts {} links {} files {} filesizes {} sizes {} times {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {} opts $opts errors $errors] } if {[string match "*TWAPI_WIN32 59*" $::errorCode]} { puts stderr "[file dirname $folderpath] '[file tail $folderpath]':$args (possibly blocked by permissions or share config e.g follow symlinks = no on samba)" puts stderr " (errorcode: $::errorCode)\n" - return [list dirs {} vfsmounts {} links {} files {} filesizes {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {}] + dict lappend errors $folderpath $::errorCode + return [list dirs {} vfsmounts {} links {} files {} filesizes {} sizes {} times {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {} opts $opts errors $errors] } - + #errorcode TWAPI_WIN32 2 {The system cannot find the file specified.} + #This can be a perfectly normal failure to match the glob.. which means we shouldn't really warn or error + #The find-all glob * won't get here because it returns . & .. + #so we should return immediately only if the glob has globchars ? or * but isn't equal to just "*" ? (review) + #Note that windows glob ? seems to return more than just single char results - it includes .. - which differs to tcl glob + #also ???? seems to returns items 4 or less - not just items exactly 4 long (review - where is this documented?) + if {$opt_glob ne "*" && [regexp {[?*]} $opt_glob]} { + if {[string match "*TWAPI_WIN32 2 *" $::errorCode]} { + #looks like an ordinary no results for chosen glob + return [list dirs {} vfsmounts {} links {} files {} filesizes {} sizes {} times {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {} opts $opts errors $errors] + } + } if {[set plen [pathcharacterlen $folderpath]] >= 250} { @@ -503,15 +615,17 @@ namespace eval punk::du { set errmsg "error reading folder: $folderpath (len:$plen)\n" append errmsg "error: $args" \n append errmsg "errorcode: $::errorCode" \n + set tmp_errors [list $::errorCode] #possibly an illegal windows filename - easily happens on a machine with WSL or with drive mapped to unix share #we can use //?/path dos device path - but not with tcl functions #unfortunately we can't call find_file_open directly on the problem name - we have to call the parent folder and iterate through again.. #this gets problematic as we go deeper unless we rewrite the .. but we can get at least one level further here + set fixedtail "" + set parent [file dirname $folderpath] set badtail [file tail $folderpath] set iterator [twapi::find_file_open [file join $parent *] -detail full] ;#retrieve with altnames - set fixedtail "" while {[twapi::find_file_next $iterator iteminfo]} { set nm [dict get $iteminfo name] if {$nm eq $badtail} { @@ -521,9 +635,11 @@ namespace eval punk::du { } if {![string length $fixedtail]} { + dict lappend errors $folderpath {*}$tmp_errors puts stderr "[file dirname $folderpath] '[file tail $folderpath]':$args (Unable to retrieve altname to progress further with path - returning no contents for this folder)" - return [list dirs {} vfsmounts {} links {} files {} filesizes {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {}] + return [list dirs {} vfsmounts {} links {} files {} filesizes {} sizes {} times {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {} opts $opts errors $errors] } + #twapi as at 2023-08 doesn't seem to support //?/ dos device paths.. #Tcl can test only get as far as testing existence of illegal name by prefixing with //?/ - but can't glob inside it #we can call file attributes on it - but we get no shortname (but we could get shortname for parent that way) @@ -537,21 +653,35 @@ namespace eval punk::du { } - - set iterator [twapi::find_file_open $fixedpath/* -detail basic] + if {[catch { + set iterator [twapi::find_file_open $fixedpath/* -detail basic] + } errMsg]} { + puts stderr "[file dirname $folderpath] '[file tail $folderpath]':$args (failed to read even with fixedpath:'$fixedpath')" + puts stderr " (errorcode: $::errorCode)\n" + puts stderr "$errMsg" + dict lappend errors $folderpath $::errorCode + return [list dirs {} vfsmounts {} links {} files {} filesizes {} sizes {} times {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {} opts $opts errors $errors] + } } on error args { set errmsg "error reading folder: $folderpath\n" - append errmsg "error: $args" - append errmsg "aborting.." - error $errmsg + append errmsg "error: $args" \n + append errmsg "errorInfo: $::errorInfo" \n + puts stderr "$errmsg" + puts stderr "FAILED to collect info for folder '$folderpath'" + #append errmsg "aborting.." + #error $errmsg + return [list dirs {} vfsmounts {} links {} files {} filesizes {} sizes {} times {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {} opts $opts errors $errors] } } set dirs [list] set files [list] set filesizes [list] + set allsizes [dict create] + set alltimes [dict create] + set links [list] set flaggedhidden [list] set flaggedsystem [list] @@ -559,13 +689,19 @@ namespace eval punk::du { while {[twapi::find_file_next $iterator iteminfo]} { set nm [dict get $iteminfo name] + #recheck glob + #review! + if {![string match $opt_glob $nm]} { + continue + } set tail_altname [dict get $iteminfo altname] ;#altname of tail - not whole path set attrinfo [decode_win_attributes [dict get $iteminfo attrs]] #puts stderr "$iteminfo" #puts stderr "$nm -> [dict get $iteminfo attrs] -> $attrinfo" - + set ftype "" #attributes applicable to any classification set fullname [file_join_one $folderpath $nm] + if {"hidden" in $attrinfo} { lappend flaggedhidden $fullname } @@ -578,6 +714,13 @@ namespace eval punk::du { #main classification if {"reparse_point" in $attrinfo} { + #this concept doesn't correspond 1-to-1 with unix links + #https://learn.microsoft.com/en-us/windows/win32/fileio/reparse-points + #review - and see which if any actually belong in the links key of our return + + + #One thing it could be, is a 'mounted folder' https://learn.microsoft.com/en-us/windows/win32/fileio/determining-whether-a-directory-is-a-volume-mount-point + # #we will treat as zero sized for du purposes.. review - option -L for symlinks like BSD du? #Note 'file readlink' can fail on windows - reporting 'invalid argument' - according to tcl docs, 'On systems that don't support symbolic links this option is undefined' #The link may be viewable ok in windows explorer, and cmd.exe /c dir and unix tools such as ls @@ -593,33 +736,70 @@ namespace eval punk::du { #Note also - a shortcut created in explorer with drag and drop to an existant folder is a different animal to a symlink (file with .lnk extension) even though it looks the same in explorer window. # #links are techically files too, whether they point to a file/dir or nothing. + lappend links $fullname + set ftype "l" } elseif {"directory" in $attrinfo} { if {$nm in {. ..}} { continue } lappend dirs $fullname + set ftype "d" } else { #review - is anything that isn't a reparse_point or a directory, some sort of 'file' in this context? What about the 'device' attribute? Can that occur in a directory listing of some sort? lappend files $fullname - lappend filesizes [dict get $iteminfo size] + if {"f" in $sized_types} { + lappend filesizes [dict get $iteminfo size] + } + set ftype "f" + } + if {$ftype in $sized_types} { + dict set allsizes $fullname [dict create bytes [dict get $iteminfo size]] + } + if {$ftype in $timed_types} { + #convert time from windows (100ns units since jan 1, 1601) to Tcl time (seconds since Jan 1, 1970) + #We lose some precision by not passing the boolean to the large_system_time_to_secs_since_1970 function which returns fractional seconds + #but we need to maintain compatibility with other platforms and other tcl functions so if we want to return more precise times we will need another flag and/or result dict + dict set alltimes $fullname [dict create\ + c [twapi::large_system_time_to_secs_since_1970 [dict get $iteminfo ctime]]\ + a [twapi::large_system_time_to_secs_since_1970 [dict get $iteminfo atime]]\ + m [twapi::large_system_time_to_secs_since_1970 [dict get $iteminfo mtime]]\ + ] } } twapi::find_file_close $iterator set vfsmounts [get_vfsmounts_in_folder $folderpath] + + set effective_opts $opts + dict set effective_opts -with_times $timed_types + dict set effective_opts -with_sizes $sized_types + #also determine whether vfs. file system x is *much* faster than file attributes #whether or not there is a corresponding file/dir add any applicable mountpoints for the containing folder - return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes $filesizes flaggedhidden $flaggedhidden flaggedsystem $flaggedsystem flaggedreadonly $flaggedreadonly altname $altname] + return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes $filesizes sizes $allsizes times $alltimes flaggedhidden $flaggedhidden flaggedsystem $flaggedsystem flaggedreadonly $flaggedreadonly altname $altname opts $effective_opts errors $errors] } proc get_vfsmounts_in_folder {folderpath} { set vfsmounts [list] + if {![llength [package provide vfs]]} { + return [list] + } + set fpath [punk::objclone $folderpath] + set is_rel 0 + if {[file pathtype $fpath] ne "absolute"} { + set fpath [file normalize $fpath] + set is_rel 1 + } set known_vfs_mounts [vfs::filesystem info] foreach mount $known_vfs_mounts { - if {[punk::repo::path_a_above_b $folderpath $mount]} { - if {([llength [file split $mount]] - [llength [file split $folderpath]]) == 1} { + if {[punk::mix::base::lib::path_a_above_b $fpath $mount]} { + if {([llength [file split $mount]] - [llength [file split $fpath]]) == 1} { #the mount is in this folder - lappend vfsmounts $mount + if {$is_rel} { + lappend vfsmounts [file join $folderpath [file tail $mount]] + } else { + lappend vfsmounts $mount + } } } } @@ -636,7 +816,66 @@ namespace eval punk::du { #this is the cross-platform pure-tcl version - which calls glob multiple times to make sure it gets everythign it needs and can ignore everything it needs to. #These repeated calls to glob will be a killer for performance - especially on a network share or when walking a large directory structure - proc du_dirlisting_generic {folderpath} { + proc du_dirlisting_generic {folderpath args} { + set defaults [dict create\ + -glob *\ + -with_sizes 0\ + -with_times 0\ + ] + set errors [dict create] + set known_opts [dict keys $defaults] + foreach k [dict keys $args] { + if {$k ni $known_opts} { + error "du_dirlisting_generic unknown-option $k" + } + } + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_glob [dict get $opts -glob] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_with_sizes [dict get $opts -with_sizes] + set ftypes [list f d l] + if {"$opt_with_sizes" in {0 1}} { + #dn't use string is boolean (false vs f problem) + if {$opt_with_sizes} { + set sized_types $ftypes + } else { + set sized_types [list] + } + } else { + set sized_types $opt_with_sizes + } + if {[llength $sized_types]} { + foreach st $sized_types { + if {$st ni $ftypes} { + error "du_dirlisting_generic unrecognized element in -with_sizes '$st'" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_with_times [dict get $opts -with_times] + if {"$opt_with_times" in {0 1}} { + if {$opt_with_times} { + set timed_types $ftypes + } else { + set timed_types [list] + } + } else { + set timed_types $opt_with_times + } + if {[llength $timed_types]} { + foreach item $timed_types { + if {$item ni $ftypes} { + error "du_dirlisting_generic unrecognised element in -with-times '$item'" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + # The repeated globs are a source of slowness for this function. + #TODO - we could minimize the number of globs if we know we need to do a file stat and/or file attributes on each entry anyway + #For the case where we don't need times,sizes or other metadata - it is faster to do multiple globs + #This all makes this function complicated to gather the required data efficiently. + #note platform differences between what is considered hidden make this tricky. # on windows 'glob .*' will not return some hidden dot items but will return . .. and glob -types hidden .* will not return some dotted items # glob -types hidden * on windows will not necessarily return all dot files/folders @@ -644,28 +883,87 @@ namespace eval punk::du { # we need to process * and .* in the same glob calls and remove duplicates # if we do * and .* in separate iterations of this loop we lose the ability to filter duplicates easily - #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' - #set parent [lindex $folders $folderidx] - set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*] - #set hdirs {} - set dirs [glob -nocomplain -dir $folderpath -types d * .*] + #note - with this design, we can't glob for all except dotfiles - this is for cross-platform consistency and efficiency (Review). + #dotfiles aren't considered hidden on all platforms + #some sort of antiglob is a possible enhancement and more consistent with the view that leading dot should be treated as any other filename character in this context. + if {$opt_glob eq "*"} { + #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' + #set parent [lindex $folders $folderidx] + set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*] + #set hdirs {} + set dirs [glob -nocomplain -dir $folderpath -types d * .*] + + set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*] + #set hlinks {} + set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. struct::set difference will remove + #set links [lsort -unique [concat $hlinks $links[unset links]]] + + set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} * .*] + #set hfiles {} + set files [glob -nocomplain -dir $folderpath -types f * .*] + #set files {} + } else { + set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} $opt_glob] + set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] - set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*] - #set hlinks {} - set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. struct::set difference will remove - #set links [lsort -unique [concat $hlinks $links[unset links]]] + set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob] + set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. struct::set difference will remove - set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} * .*] - #set hfiles {} - set files [glob -nocomplain -dir $folderpath -types f * .*] - #set files {} + set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob] + set files [glob -nocomplain -dir $folderpath -types f $opt_glob] + } #note struct::set difference produces unordered result #struct::set difference removes duplicates #remove links and . .. from directories, remove links from files - set dirs [struct::set difference [concat $hdirs $dirs[unset dirs]] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] set files [struct::set difference [concat $hfiles $files[unset files]] $links] + set dirs [struct::set difference [concat $hdirs $dirs[unset dirs]] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] set links [lsort -unique [concat $links $hlinks]] + + set meta_dict [dict create] + set meta_types [concat $sized_types $timed_types] + #known tcl stat keys 2023 - review + set empty_stat_dict [dict create atime {} ctime {} dev {} gid {} ino {} mode {} mtime {} nlink {} size {} type {} uid {}] + #make sure we call file stat only once per item + set statkeys [list] + if {[llength $meta_types]} { + foreach ft {f d l} lvar {files dirs links} { + if {"$ft" in $meta_types} { + foreach path [set $lvar] { + #caller may have read perm on the containing folder - but not on child item - so file stat could raise an error + if {![catch {file stat $path arrstat} errM]} { + dict set meta_dict $path [dict create shorttype $ft {*}[array get arrstat]] + } else { + dict lappend errors $path "file stat error: $errM" + dict set meta_dict $path [dict create shorttype $ft {*}$empty_stat_dict] + } + } + } + } + } + set fsizes [list] + set allsizes [dict create] + set alltimes [dict create] + #review birthtime field of stat? cross-platform differences ctime etc? + dict for {path pathinfo} $meta_dict { + set ft [dict get $pathinfo shorttype] + if {$ft in $sized_types} { + dict set allsizes $path [dict create bytes [dict get $pathinfo size]] + if {$ft eq "f"} { + lappend fsizes [dict get $pathinfo size] + } + } + if {$ft in $timed_types} { + dict set alltimes $path [dict create c [dict get $pathinfo ctime] a [dict get $pathinfo atime] m [dict get $pathinfo mtime]] + } + } + if {"f" in $sized_types} { + if {[llength $fsizes] ne [llength $files]} { + dict lappend errors $folderpath "failed to retrieve all file sizes" + } + } + + if {"windows" eq $::tcl_platform(platform)} { set flaggedhidden [concat $hdirs $hfiles $hlinks] } else { @@ -676,32 +974,202 @@ namespace eval punk::du { set vfsmounts [get_vfsmounts_in_folder $folderpath] - set filesizes [list]; #not available in listing-call - as opposed to twapi which can do it as it goes - return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {}] + set effective_opts $opts + dict set effective_opts -with_times $timed_types + dict set effective_opts -with_sizes $sized_types + + return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes $fsizes sizes $allsizes times $alltimes flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {} opts $effective_opts errors $errors] } - #we can halve the number of round trips on unix-like systems, where 'hidden' always corresponds to dotted files - proc du_dirlisting_unix {folderpath} { - set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs - set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove - set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files + proc du_dirlisting_tclvfs {folderpath args} { + set defaults [dict create\ + -glob *\ + -with_sizes 0\ + -with_times 0\ + ] + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_glob [dict get $opts -glob] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_with_sizes [dict get $opts -with_sizes] + set ftypes [list f d l] + if {"$opt_with_sizes" in {0 1}} { + #dn't use string is boolean (false vs f problem) + if {$opt_with_sizes} { + set sized_types $ftypes + } else { + set sized_types [list] + } + } else { + set sized_types $opt_with_sizes + } + if {[llength $sized_types]} { + foreach st $sized_types { + if {$st ni $ftypes} { + error "du_dirlisting_generic unrecognized element in -with_sizes '$st'" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_with_times [dict get $opts -with_times] + if {"$opt_with_times" in {0 1}} { + if {$opt_with_times} { + set timed_types $ftypes + } else { + set timed_types [list] + } + } else { + set timed_types $opt_with_times + } + if {[llength $timed_types]} { + foreach item $timed_types { + if {$item ni $ftypes} { + error "du_dirlisting_generic unrecognised element in -with-times '$item'" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + + set errors [dict create] + if {$opt_glob eq "*"} { + set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs + #review - how are links handled in vfs? presumably if the vfs is a full implementation they should work at least within the vfs? + set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove + set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files + } else { + set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] + set links [glob -nocomplain -dir $folderpath -types l $opt_glob] + set files [glob -nocomplain -dir $folderpath -types f $opt_glob] + } #remove any links from our dirs and files collections set dirs [struct::set difference $dirs[unset dirs] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] set files [struct::set difference $files[unset files] $links] + #nested vfs mount.. REVIEW - does anything need special handling? set vfsmounts [get_vfsmounts_in_folder $folderpath] - return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {}] + + set meta_dict [dict create] + set meta_types [concat $sized_types $timed_types] + #known tcl stat keys 2023 - review + set empty_stat_dict [dict create atime {} ctime {} dev {} gid {} ino {} mode {} mtime {} nlink {} size {} type {} uid {}] + #make sure we call file stat only once per item + set statkeys [list] + if {[llength $meta_types]} { + foreach ft {f d l} lvar {files dirs links} { + if {"$ft" in $meta_types} { + foreach path [set $lvar] { + #caller may have read perm on the containing folder - but not on child item - so file stat could raise an error + if {![catch {file stat $path arrstat} errM]} { + dict set meta_dict $path [dict create shorttype $ft {*}[array get arrstat]] + } else { + dict lappend errors $path "file stat error: $errM" + dict set meta_dict $path [dict create shorttype $ft {*}$empty_stat_dict] + } + } + } + } + } + set fsizes [list] + set allsizes [dict create] + set alltimes [dict create] + #review birthtime field of stat? cross-platform differences ctime etc? + dict for {path pathinfo} $meta_dict { + set ft [dict get $pathinfo shorttype] + if {$ft in $sized_types} { + dict set allsizes $path [dict create bytes [dict get $pathinfo size]] + if {$ft eq "f"} { + lappend fsizes [dict get $pathinfo size] + } + } + if {$ft in $timed_types} { + dict set alltimes $path [dict create c [dict get $pathinfo ctime] a [dict get $pathinfo atime] m [dict get $pathinfo mtime]] + } + } + if {"f" in $sized_types} { + if {[llength $fsizes] ne [llength $files]} { + dict lappend errors $folderpath "failed to retrieve all file sizes" + } + } + + + set effective_opts $opts + dict set effective_opts -with_times $timed_types + dict set effective_opts -with_sizes $sized_types + + return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes $fsizes sizes $allsizes times $alltimes flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {} opts $effective_opts errors $errors] } - proc du_dirlisting_tclvfs {folderpath} { - set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs - #review - how are links handled in vfs? presumably if the vfs is a full implementation they should work at least within the vfs? - set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove - set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files + + #we can halve the number of round trips on unix-like systems, where 'hidden' always corresponds to dotted files + proc du_dirlisting_unix {folderpath args} { + set defaults [dict create\ + -glob *\ + -with_sizes 0\ + -with_times 0\ + ] + set errors [dict create] + dict lappend errors $folderpath "metdata support incomplete - prefer du_dirlisting_generic" + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_glob [dict get $opts -glob] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_with_sizes [dict get $opts -with_sizes] + set ftypes [list f d l] + if {"$opt_with_sizes" in {0 1}} { + #dn't use string is boolean (false vs f problem) + if {$opt_with_sizes} { + set sized_types $ftypes + } else { + set sized_types [list] + } + } else { + set sized_types $opt_with_sizes + } + if {[llength $sized_types]} { + foreach st $sized_types { + if {$st ni $ftypes} { + error "du_dirlisting_generic unrecognized element in -with_sizes '$st'" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_with_times [dict get $opts -with_times] + if {"$opt_with_times" in {0 1}} { + if {$opt_with_times} { + set timed_types $ftypes + } else { + set timed_types [list] + } + } else { + set timed_types $opt_with_times + } + if {[llength $timed_types]} { + foreach item $timed_types { + if {$item ni $ftypes} { + error "du_dirlisting_generic unrecognised element in -with-times '$item'" + } + } + } + + #this is not consistent with standard way * works for unix folders - but it is consistent with behaviour of this facility on windows + if {$opt_glob eq "*"} { + set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs + set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove + set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files + } else { + set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] + set links [glob -nocomplain -dir $folderpath -types l $opt_glob] + set files [glob -nocomplain -dir $folderpath -types f $opt_glob] + } #remove any links from our dirs and files collections set dirs [struct::set difference $dirs[unset dirs] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] set files [struct::set difference $files[unset files] $links] - #nested vfs mount.. REVIEW - does anything need special handling? set vfsmounts [get_vfsmounts_in_folder $folderpath] - return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {}] + + set effective_opts $opts + dict set effective_opts -with_times $timed_types + dict set effective_opts -with_sizes $sized_types + + + return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes {} times {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {} opts $opts errors $errors] } @@ -740,9 +1208,15 @@ namespace eval punk::du { return $newlist } - #just an experiment + #same implementation as punk::strlen #get length of path which has internal rep of path - maintaining path/list rep without shimmering to string representation. proc pathcharacterlen {pathrep} { + append str2 $pathrep {} + string length $str2 + } + #just an experiment + proc pathcharacterlen1 {pathrep} { + #This works - but is unnecessarily complex set l 0 set parts [file split $pathrep] if {[llength $parts] < 2} { @@ -769,6 +1243,26 @@ namespace eval punk::du { } } + proc du_dirlisting_undecided {folderpath args} { + if {"windows" eq $::tcl_platform(platform)} { + set loadstate [zzzload::pkg_require twapi] + if {$loadstate ni [list loading failed]} { + package require twapi ;#should be fast once twapi dll loaded in zzzload thread + set ::punk::du::has_twapi 1 + punk::du::active::set_active_function du_dirlisting du_dirlisting_twapi + tailcall du_dirlisting_twapi $folderpath {*}$args + } else { + if {$loadstate eq "failed"} { + puts stderr "punk::du defaulting to du_dirlisting_generic because twapi load failed" + punk::du::active::set_active_function du_dirlisting du_dirlisting_generic + } + tailcall du_dirlisting_generic $folderpath {*}$args + } + } else { + punk::du::active::set_active_function du_dirlisting du_dirlisting_unix + tailcall du_dirlisting_unix $folderpath {*}$args + } + } } @@ -791,15 +1285,8 @@ namespace eval punk::du { variable functions_kown upvar ::punk::du::has_twapi has_twapi - if {"windows" eq $::tcl_platform(platform)} { - if {$has_twapi} { - set_active_function du_dirlisting du_dirlisting_twapi - } else { - set_active_function du_dirlisting du_dirlisting_generic - } - } else { - set_active_function du_dirlisting du_dirlisting_unix - } + set_active_function du_dirlisting du_dirlisting_undecided + } diff --git a/src/bootsupport/modules/punk/mix-0.2.tm b/src/bootsupport/modules/punk/mix-0.2.tm index 10d9ca20..2988b428 100644 --- a/src/bootsupport/modules/punk/mix-0.2.tm +++ b/src/bootsupport/modules/punk/mix-0.2.tm @@ -1,1479 +1,15 @@ -package provide punk::mix [namespace eval punk::mix { - variable version - set version 0.2 - -}] - -package require punk::repo -package rqeuire punk::ns - -namespace eval punk::mix::cli { - namespace ensemble create - - proc help {args} { - #set basehelp [punk::mix::base::help -extension [namespace current] {*}$args] - set basehelp [punk::mix::base help {*}$args] - puts stdout "punk::mix help" - return $basehelp - } - - - - - proc status {{project ""}} { - set result "" - if {[string length $project]} { - puts stderr "project status unimplemented" - return - } - set active_dir [pwd] - - if {[punk::repo::is_fossil $active_dir]} { - set fosroot [punk::repo::find_fossil $active_dir] - set candroot [punk::repo::find_candidate $active_dir] - if {([string length $candroot]) && ([string tolower $fosroot] ne [string tolower $candroot])} { - - #todo - only warn if this candidate is *within* the found repo root? - append result "**" \n - append result "** found folder with /src at or above current folder - that isn't the fossil root" \n - append result "** current folder: $active_dir" \n - append result "** unexpected : $candroot" \n - append result "** fossil root : $fosroot ([punk::repo::path_relative $active_dir $fosroot])" \n - append result "** reporting based on the fossil root found." - append result "**" \n - - } - append result "FOSSIL project based at $fosroot with revision: [punk::repo::fossil_revision $active_dir]" \n - set dbinfo [exec fossil dbstat] - append result [join [punk::repo::grep {project-name:*} $dbinfo] \n] \n - append result [join [punk::repo::grep {tickets:*} $dbinfo] \n] \n - append result [join [punk::repo::grep {project-age:*} $dbinfo] \n] \n - append result [join [punk::repo::grep {latest-change:*} $dbinfo] \n] \n - append result [join [punk::repo::grep {files:*} $dbinfo] \n] \n - append result [join [punk::repo::grep {check-ins:*} $dbinfo] \n] \n - set timeline [exec fossil timeline -n 5 -t ci] - set timeline [string map [list \r\n \n] $timeline] - append result $timeline - } else { - append result "Not a punk fossil project" \n - if {[punk::repo::is_git $active_dir]} { - set gitroot [punk::repo::find_git $active_dir] - set candroot [punk::repo::find_candidate $active_dir] - if {([string length $candroot]) && ([string tolower $gitroot] ne [string tolower $candroot])} { - - append result "**" \n - append result "** found folder with /src at or above current folder - that isn't the git root" \n - append result "** current folder: $active_dir" \n - append result "** unexpected : $candroot" \n - append result "** git root : $gitroot ([punk::repo::path_relative $active_dir $gitroot])" \n - append result "** reporting based on the git root found." - append result "**" \n - - } - append result "GIT project based at [punk::repo::find_git $active_dir] with revision: [punk::repo::git_revision $active_dir]" \n - } else { - append result "No repository located for current folder $active_dir" \n - if {[string length [set candidate [punk::repo::find_candidate $active_dir]]]} { - append result "Candidate project root found at : $candidate" \n - append result " - consider putting this folder under fossil control (and/or git)" \n - } else { - append result "No candidate project root found. " - append result "Searched upwards from '$active_dir' expecting a folder with the following requirements: " \n - append result [punk::repo::is_candidate_root_requirements_msg] - } - } - } - return $result - } - proc tickets {{project ""}} { - set result "" - if {[string length $project]} { - puts stderr "project status unimplemented" - return - } - set active_dir [pwd] - append result "Retrieving top 10 tickets only (for more, use fossil timeline -n -t t)" \n - append result [exec fossil timeline -n 10 -t t] - - return $result - } - proc fossilize { args} { - #check if project already managed by fossil.. initialise and check in if not. - puts stderr "unimplemented" - } - proc unfossilize {projectname args} { - #remove/archive .fossil - puts stderr "unimplemented" - } - #new project structure - may be dedicated to one module, or contain many. - #create minimal folder structure only by specifying -modules {} - proc new {projectname args} { - lib::validate_projectname $projectname - - - set defaults [list -type plain -empty 0 -force 0 -update 0 -confirm 1 -modules \uFFFF -layout project] ;#todo - set opts [dict merge $defaults $args] - set opt_modules [dict get $opts -modules] - if {[llength $opt_modules] == 1 && [lindex $opt_modules 0] eq "\uFFFF"} { - #if not specified - add a single module matching project name - set opt_modules [list $projectname] - } - set opt_type [dict get $opts -type] - if {$opt_type ni [lib::module_types]} { - error "pmix new error - unknown type '$opt_type' known types: [lib::module_types]" - } - set opt_layout [dict get $opts -layout] - set opt_force [dict get $opts -force] - set opt_update [dict get $opts -update] - set opt_confirm [string tolower [dict get $opts -confirm]] - - set startdir [pwd] - if {[punk::repo::is_project $startdir]} { - puts stderr "Already in a project directory '$startdir' - move to a base location suitable for a new project" - puts stderr " todo: pmix newsubproject" - return - } - - set projectdir $startdir/$projectname - - - set tpldir [lib::mix_templates_dir] - if {[file exists $projectdir] && !($opt_force || $opt_update)} { - puts stderr "Unable to create new project at $projectdir - file/folder already exists use -update 1 to fill in missing items from template use -force 1 to overwrite from template" - return - } elseif {[file exists $projectdir] && $opt_force} { - puts stderr "mix new WARNING: -force 1 was supplied. Will copy layout $tpldir/layouts/$opt_layout using -force option to overwrite from template" - if {$opt_confirm ni [list 0 no false]} { - puts stdout "Do you want to proceed to possibly overwrite existing files in $projectdir? Y|N" - set stdin_state [fconfigure stdin] - fconfigure stdin -blocking 1 - set answer [string tolower [gets stdin]] - fconfigure stdin -blocking [dict get $stdin_state -blocking] - if {$answer ne "y"} { - puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." - return - } - } - } elseif {[file exists $projectdir] && $opt_update} { - puts stderr "mix new WARNING: -update 1 was supplied. Will copy layout $tpldir/layouts/$opt_layout using -update option to add missing items" - } - - - if {[file exists $startdir/$projectname.fossil]} { - puts stdout "NOTICE: $startdir/$projectname.fossil already exists" - if {!($opt_force || $opt_update)} { - puts stderr "-force 1 or -update 1 not specified - aborting" - return - } - } - - #todo - lookup config for .fossil repo location. For now use current dir. - - if {[punk::repo::is_git $startdir]} { - puts stderr "mix new WARNING: you are already within a git repo based at [punk::repo::find_git $startdir]" - puts stderr "The new project will create a fossil repository (which you are free to ignore - but but will be used to confirm project base)" - puts stderr "If you intend to use both git and fossil in the same project space - you should research and understand the details and any possible interactions/issues" - puts stdout "Do you want to proceed to create a project based at: $projectdir? Y|N" - set stdin_state [fconfigure stdin] - fconfigure stdin -blocking 1 - set answer [string tolower [gets stdin]] - fconfigure stdin -blocking [dict get $stdin_state -blocking] - if {$answer ne "y"} { - puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." - return - } - } - set is_nested_fossil 0 ;#default assumption - if {[punk::repo::is_fossil $startdir]} { - puts stderr "mix new WARNING: you are already within an open fossil repo based at [punk::repo::find_fossil $startdir] NESTED fossil repository" - if {$opt_confirm ni [list 0 no false]} { - puts stderr "If you proceed - the new project's fossil repo will be created using the --nested flag" - puts stdout "Do you want to proceed to create a NESTED project based at: $projectdir? Y|N" - set stdin_state [fconfigure stdin] - fconfigure stdin -blocking 1 - set answer [string tolwer [gets stdin]] - fconfigure stdin -blocking [dict get $stdin_state -blocking] - if {$answer ne "y"} { - puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." - return - } - set is_nested_fossil 1 - } - } - - puts stdout "Initialising fossil repo: $startdir/$projectname.fossil" - set fossilinit [runx -n fossil init $projectname.fossil -project-name $projectname] - if {[dict get $fossilinit exitcode] != 0} { - puts stderr "fossil init failed:" - puts stderr [dict get $fossilinit stderr] - return - } else { - puts stdout "fossil init result:" - puts stdout [dict get $fossilinit stdout] - } - - file mkdir $projectdir - set layout_dir $tpldir/layouts/$opt_layout - if {$opt_force} { - lib::copy_files_from_source_to_target $layout_dir $projectdir -overwrite ALL-TARGETS - #file copy -force $layout_dir $projectdir - } else { - lib::copy_files_from_source_to_target $layout_dir $projectdir - } - - #expect this in all templates? - todo make these substitutions independent of specific paths and filenames? - set readme_file $projectdir/src/README.md - if {[file exists $readme_file]} { - set fd [open $readme_file r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd - set data [string map [list %project% $projectname] $data] - set fdout [open $readme_file w]; fconfigure $fdout -translation binary; puts -nonewline $fdout $data; close $fdout - } else { - puts stderr "warning: Missing $projectdir/src/README.md" - } - #todo - tag substitutions in src/doc tree - - - cd $projectdir - - foreach m $opt_modules { - newmodule $m -project $projectname -type $opt_type -force $opt_force - } - - #generate www/man/md output in 'embedded' folder which should be checked into repo for online documentation - cd $projectdir/src - Kettle doc - - cd $projectdir - if {![punk::repo::is_fossil_root $projectdir]} { - set first_fossil 1 - #-k = keep. (only modify the manifest file(s)) - if {$is_nested_fossil} { - set fossilopen [runx -n fossil open --nested ../$projectname.fossil -k] - } else { - set fossilopen [runx -n fossil open ../$projectname.fossil -k] - } - if {[dict get $fossilopen exitcode] != 0} { - puts stderr "fossil open in project workdir '$projectdir' FAILED:" - puts stderr [dict get $fossilopen stderr] - return - } else { - puts stdout "fossil open in project workdir '$projectdir' OK:" - puts stdout [dict get $fossilopen stdout] - } - } else { - set first_fossil 0 - } - set fossiladd [runx -n fossil add --dotfiles .] - if {[dict get $fossiladd exitcode] != 0} { - puts stderr "fossil add workfiles in workdir '$projectdir' FAILED:" - puts stderr [dict get $fossiladd stderr] - return - } else { - puts stdout "fossil add workfiles in workdir '$projectdir' OK:" - puts stdout [dict get $fossiladd stdout] - } - if {$first_fossil} { - #fossil commit may prompt user for input.. runx runout etc will pause with no prompts - set fossilcommit [run -n fossil commit -m "initial project commit"] - if {[dict get $fossilcommit exitcode] != 0} { - puts stderr "fossil commit in workdir '$projectdir' FAILED" - return - } else { - puts stdout "fossil commit in workdir '$projectdir' OK" - } - } - - puts stdout "-done- project:$projectname projectdir: $projectdir" - } - interp alias {} ::punk::mix::cli::newproject {} ::punk::mix::cli::new - - #search automatically wrapped in * * - can contain inner * ? globs - proc libsearch {searchstring} { - 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 - } - set matches [lsearch -all -inline -nocase [package names] "*${searchstring}*"] - set matchinfo [list] - foreach m $matches { - set versions [package versions $m] - if {$has_natsort} { - set versions [natsort::sort $versions] - } else { - set versions [lsort $versions] - } - lappend matchinfo [list $m $versions] - } - return [join [lsort $matchinfo] \n] - } - proc libinfo {libname} { - if {[catch {package require natsort}]} { - set has_natsort 0 - } else { - set has_natsort 1 - } - catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything - set pkgsknown [package names] - if {[set posn [lsearch $pkgsknown $libname]] >= 0} { - puts stdout "Found package [lindex $pkgsknown $posn]" - } else { - puts stderr "Package not found as available library/module - check tcl::tm::list and \$auto_path" - } - set versions [package versions [lindex $libname 0]] - if {$has_natsort} { - set versions [natsort::sort $versions] - } else { - set versions [lsort $versions] - } - if {![llength $versions]} { - puts stderr "No version numbers found for library/module $libname" - return false - } - puts stdout "Versions of $libname found: $versions" - set alphaposn [lsearch $versions "999999.*"] - if {$alphaposn >= 0} { - set alpha [lindex $versions $alphaposn] - #remove and tack onto beginning.. - set versions [lreplace $versions $alphaposn $alphaposn] - set versions [list $alpha {*}$versions] - } - foreach ver $versions { - set loadinfo [package ifneeded $libname $ver] - puts stdout "$libname $ver" - puts stdout "--- 'package ifneeded' script ---" - puts stdout $loadinfo - puts stdout "---" - } - return - } - proc libcopy_as_module {library modulefoldername args} { - set defaults [list -askme 1] - set opts [dict merge $defaults $args] - set opt_askme [dict get $opts -askme] - - if {[catch {package require natsort}]} { - set has_natsort 0 - } else { - set has_natsort 1 - } - - catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything - - if {[file pathtype $modulefoldername] eq "absolute"} { - if {![file exists $modulefoldername]} { - error "Path '$modulefoldername' not found. Enter a fully qualified path, or just the tail such as 'modules' if you are within the project to use /src/modules" - } - #use the target folder as the source of projectdir info - set pathinfo [punk::repo::find_roots_and_warnings_dict $modulefoldername] - set projectdir [dict get $pathinfo closest] - set modulefolder_path $modulefoldername - } else { - #use the current working directory as the source of projectdir info - set pathinfo [punk::repo::find_roots_and_warnings_dict [pwd]] - set projectdir [dict get $pathinfo closest] - set modulefolders [lib::find_source_module_paths $projectdir] - foreach k [list modules bootsupport vendormodules] { - set knownfolder [file join $projectdir src $k] - if {$knownfolder ni $modulefolders} { - lappend modulefolders $knownfolder - } - } - set mtails [list] - foreach path $modulefolders { - lappend mtails [file tail $path] - } - if {$modulefoldername ni $mtails} { - set msg "Suplied modulefoldername '$modulefoldername' doesn't appear to be a known module folder within the project at $projectdir\n" - append msg "Known module folders: [lsort $mtails]\n" - append msg "Use a name from the above list, or a fully qualified path\n" - error $msg - } - - set modulefolder_path [file join $projectdir src $modulefoldername] - - } - puts stdout "-----------------------------" - puts stdout "Using projectdir: $projectdir for libcopy_as_module" - puts stdout "-----------------------------" - - - set libfound [lsearch -all -inline [package names] $library] - if {[llength $libfound] != 1 || ![string length $libfound]} { - error "Library must match exactly one entry in the list of package names visible to the current interpretor: found '$libfound'" - } - - set versions [package versions [lindex $libfound 0]] - if {$has_natsort} { - set versions [natsort::sort $versions] - } else { - set versions [lsort $versions] - } - if {![llength $versions]} { - error "No version numbers found for library/module $libfound - sorry, you will need to copy it across manually" - } - puts stdout "Versions of $libfound found: $versions" - set alphaposn [lsearch $versions "999999.*"] - if {$alphaposn >= 0} { - set alpha [lindex $versions $alphaposn] - #remove and tack onto beginning.. - set versions [lreplace $versions $alphaposn $alphaposn] - set versions [list $alpha {*}$versions] - } - - set ver [lindex $versions end] ;# todo - make selectable! don't assume tail is latest?.. package vcompare? - if {[llength $versions] > 1} { - puts stdout "Version selected: $ver" - } - - set loadinfo [package ifneeded $libfound $ver] - if {[llength $loadinfo] == 2 && [lindex $loadinfo 0] eq "source"} { - set source_file [lindex $loadinfo 1] - } elseif {[string match "*source*" $loadinfo]} { - set parts [list] - set loadinfo [string map [list \r\n \n] $loadinfo] - set lines [split $loadinfo \n] - foreach ln $lines { - lappend parts {*}[split $loadinfo ";"] - } - set sources_found [list] - set loads_found [list] - set dependencies [list] - set incomplete_lines [list] - foreach p $parts { - set p [string trim $p] - if {![string length $p]} { - continue ;#empty line or trailing colon - } - if {![info complete $p]} { - # - #probably a perfectly valid script - but slightly more complicated than we can handle - #better to defer to manual processing - lappend incomplete_lines $p - continue - } - if {[lindex $p 0] eq "source"} { - #may have args.. e.g -encoding utf-8 - lappend sources_found [lindex $p end] - } - if {[lindex $p 0] eq "load"} { - lappend loads_found [lrange $p 1 end] - } - if {[lrange $p 0 1] eq "package require"} { - lappend dependencies [lrange $p 2 end] - } - } - if {[llength $incomplete_lines]} { - puts stderr "unable to interpret load script for library $libfound" - puts stderr "Load info: $loadinfo" - return false - } - if {[llength $loads_found]} { - puts stderr "package $libfound appears to have binary components" - foreach l $loads_found { - puts stderr " binary - $l" - } - foreach s $sources_found { - puts stderr " script - $s" - } - puts stderr "Unable to automatically copy binary libraries to your module folder." - return false - } - - if {[llength $sources_found] != 1} { - puts stderr "sorry - unable to interpreet source library location" - puts stderr "Only 1 source supported for now" - puts stderr "Load info: $loadinfo" - return false - } - if {[llength $dependencies]} { - puts stderr "WARNING the package appears to depend on at least one other. Review and copy dependencies as required." - foreach d $dependencies { - puts stderr " - $d" - } - } - - set source_file [lindex $sources_found 0] - } else { - puts stderr "sorry - unable to interpret source library location" - puts stderr "Load info: $loadinfo" - return false - } - - if {![file exists $source_file]} { - error "Unable to verify source file existence at: $source_file" - } - set source_data [fcat $source_file -translation binary] - if {![string match "*package provide*" $source_data] || ![string match "*$libfound*" $source_data]} { - puts stderr "Sorry - unable to verify source file contains 'package provide' and '$libfound' - copy manually" - return false - } - - set moduleprefix [punk::ns::nsprefix $libfound] - if {[string length $moduleprefix]} { - set moduleprefix_parts [punk::ns::nsparts $moduleprefix] - set relative_path [file join {*}$moduleprefix_parts] - } else { - set relative_path "" - } - set pkgtail [punk::ns::nstail $libfound] - set target_path [file join $modulefolder_path $relative_path ${pkgtail}-${ver}.tm] - - if {$opt_askme} { - puts stdout "WARNING - you should check that there aren't extra required files for the library/modules" - puts stdout "" - puts stdout "This is not intended for binary modules - use at own risk and check results" - puts stdout "" - puts stdout "Base module path: $modulefolder_path" - puts stdout "Target path : $target_path" - puts stdout "results of 'package ifneeded $libfound'" - puts stdout "---" - puts stdout "$loadinfo" - puts stdout "---" - puts stdout "Proceed to create ${pkgtail}-${ver}.tm module? Y|N" - set stdin_state [fconfigure stdin] - fconfigure stdin -blocking 1 - set answer [string tolower [gets stdin]] - fconfigure stdin -blocking [dict get $stdin_state -blocking] - if {$answer ne "y"} { - puts stderr "mix libcopy_as_module aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." - return - } - } - - if {![file exists $modulefolder_path]} { - puts stdout "Creating module base folder at $modulefolder_path" - file mkdir $modulefolder_path - } - if {![file exists [file dirname $target_path]]} { - puts stdout "Creating relative folder at [file dirname $target_path]" - file mkdir [file dirname $target_path] - } - - if {[file exists $target_path]} { - puts stdout "WARNING - module already exists at $target_path" - if {$opt_askme} { - puts stdout "Copy anyway? Y|N" - set stdin_state [fconfigure stdin] - fconfigure stdin -blocking 1 - set answer [string tolower [gets stdin]] - fconfigure stdin -blocking [dict get $stdin_state -blocking] - if {$answer ne "y"} { - puts stderr "mix libcopy_as_module aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." - return - } - } - } - - file copy -force $source_file $target_path - - return $target_path - } - - proc wrap_in_multishell {filepath args} { - set defaults [list -askme 1] - set opts [dict merge $defaults $args] - - set opt_askme [dict get $opts -askme] - - if {[file type $filepath] ne "file"} { - error "wrap_in_multishell: only script files can be wrapped." - } - set ext [string trim [file extension $filepath] .] - #set allowed_extensions [list tcl ps1 sh bash] - #TODO - set allowed_extensions [list tcl] - if {[string tolower $ext] ni $allowed_extensions} { - error "wrap_in_multishell: script must have file extension in list: $allowed_extensions" - } - - set output_file [file rootname $filepath].cmd - if {[file exists $output_file]} { - error "wrap_in_multishell: target file $output_file already exists.. aborting" - } - - - set startdir [pwd] - set workroot [punk::repo::find_candidate $startdir] - set wrapper_template $workroot/src/ - - set tpldir [lib::mix_templates_dir] - set wrapper_template $tpldir/utility/multishell.cmd - if {![file exists $wrapper_template]} { - error "wrap_in_multishell: unable to find multishell template at $wrapper_template" - } - set fdt [open $wrapper_template r] - fconfigure $fdt -translation binary - set template_data [read $fdt] - close $fdt - puts stdout "Read [string length $template_data] bytes of template data.." - set template_lines [split $template_data \n] - puts stdout "Displaying first 3 lines of template between dashed lines..." - puts stdout "-----------------------------------------------" - foreach ln [lrange $template_lines 0 3] { - puts stdout $ln - } - puts stdout "-----------------------------------------------\n" - #foreach ln $template_lines { - #} - - set fdscript [open $filepath r] - fconfigure $fdscript -translation binary - set script_data [read $fdscript] - close $fdscript - puts stdout "Read [string length $script_data] bytes of template data.." - set script_lines [split $script_data \n] - puts stdout "Displaying first 3 lines of your script between dashed lines..." - puts stdout "-----------------------------------------------" - foreach ln [lrange $script_lines 0 3] { - puts stdout $ln - } - puts stdout "-----------------------------------------------\n" - if {$opt_askme} { - puts stdout "Target for above data is '$output_file'" - puts stdout "Does this look correct? Y|N" - set stdin_state [fconfigure stdin] - fconfigure stdin -blocking 1 - set answer [gets stdin] - if {[string tolower $answer] ne "y"} { - fconfigure stdin -blocking [dict get $stdin_state -blocking] - - puts stderr "mix new aborting due to user response '$answer' (required Y or y to proceed) use -askme 0 to avoid prompts." - return - } - fconfigure stdin -blocking [dict get $stdin_state -blocking] - } - - set start_idx 0 - set end_idx 0 - set line_idx 0 - set existing_payload [list] - foreach ln $template_lines { - - if {[string match "#*" $ln]} { - set start_idx $line_idx - } elseif {[string match "#*" $ln]} { - set end_idx $line_idx - break - } elseif {$start_idx > 0} { - if {$end_idx > 0} { - lappend existing_payload [string trim $ln] - } - } else { - - } - incr line_idx - } - if {($start_idx == 0) || ($end_idx == 0)} { - error "wrap_in_multishell was unable to find payload area in template marked with # and # on separate lines" - } - set existing_string [join $existing_payload \n] - if {[string length [string trim $existing_string]]} { - puts stdout "EXISTING PAYLOAD!!" - puts stdout "-----------------------------------------------\n" - puts stdout $existing_string - puts stdout "-----------------------------------------------\n" - error "wrap_in_multishell found existing payload.. aborting." - #todo - allow overwrite only in files outside of punkshell distribution? - if 0 { - puts stderr "Found existing payload.. overwrite?" - if {$opt_askme} { - puts stdout "Are you sure you want to replace the tcl payload shown above? Y|N" - fconfigure stdin -blocking 1 - set answer [string tolower [gets stdin]] - fconfigure stdin -blocking [dict get $stdin_state -blocking] - if {$answer ne "y"} { - puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." - return - } - } - } - } - set tpl_head_lines [lrange $template_lines 0 $start_idx] ;#include tag line - set tpl_tail_lines [lrange $template_lines $end_idx end] - set newscript [join $tpl_head_lines \n]\n[join $script_lines \n]\n[join $tpl_tail_lines \n] - puts stdout "New script is [string length $newscript] bytes" - puts stdout $newscript - set fdtarget [open $output_file w] - fconfigure $fdtarget -translation binary - puts -nonewline $fdtarget $newscript - close $fdtarget - puts stdout "Wrote script file at $output_file" - puts stdout "-done-" - return $output_file - } +package require punk::cap +package require punk::mix::templates ;#registers 'templates' capability with punk::cap +package require punk::mix::base +package require punk::mix::cli - #require current dir when calling to be the projectdir, or - proc newmodule {module args} { - set year [clock format [clock seconds] -format %Y] - set defaults [list -project \uFFFF -type \uFFFF -version 0.1.0 -force 0 -license ] - set opts [dict merge $defaults $args] - set opt_project [dict get $opts -project] - set opt_version [dict get $opts -version] - set opt_license [dict get $opts -license] - - if {[string first - $module]> 0} { - set vparts [lassign [split $module -] modulename] - set mversion [join $vparts -] ;# (- not supported in tcl versions for 8.7 - but possibly part of 9+ if semver implemented) - if {![lib::is_valid_tm_version $mversion]} { - error "pmix newmodule error - unable to determine modulename-version from supplied value '$module'" - } - if {[package vcompare $mversion $opt_version] > 0} { - set opt_version $mversion; #module parameter has higher value than -version - } - } else { - set modulename $module - - } - lib::validate_modulename $modulename "mix newmodule name" - - - set testdir [pwd] - if {![string length [set projectdir [punk::repo::find_project $testdir]]]} { - if {![string length [set projectdir [punk::repo::find_candidate $testdir]]]} { - error "newmodule unable to create module in projectdir:$projectdir - directory doesn't appear to meet basic standards (/src, src/modules, src/lib & /modules must exist, must not be a system path such as /usr/bin or c:/windows)" - } - } - - if {$opt_project == "\uFFFF"} { - set projectname [file tail $projectdir] - } else { - set projectname $opt_project - if {$projectname ne [file tail $projectdir]} { - error "newmodule -project '$opt_project' doesn't match detected projectname '$projectname' at path: $projectdir" - } - } - - set opt_type [dict get $opts -type] - if {$opt_type eq "\uFFFF"} { - set opt_type [lindex [lib::module_types] 0] ;#default to plain - } - if {$opt_type ni [lib::module_types]} { - error "mix newmodule - error - unknown -type '$opt_type' known-types: [lib::module_types]" - } - - set subpath [lib::module_subpath $modulename] ;#commonly empty string for simple modulename e.g "mymodule" but x::mymodule has subpath 'x' and x::y::mymodule has subpath 'x/y' - if {![string length $subpath]} { - set modulefolder $projectdir/src/modules - } else { - set modulefolder $projectdir/src/modules/$subpath - } - file mkdir $modulefolder - - set moduletail [namespace tail $modulename] - set tpldir [lib::mix_templates_dir] - set magicversion [lib::magic_tm_version] ;#deliberately large so given load-preference when testing - - - set fd [open $tpldir/module/module_buildversion.txt r]; set filedata [read $fd]; close $fd - set filedata [string map [list %Major.Minor.Level% $opt_version] $filedata] - set fd [open $modulefolder/${moduletail}-buildversion.txt w] - fconfigure $fd -translation binary - puts -nonewline $fd $filedata - close $fd - - set tpldir [lib::mix_templates_dir] - set fd [open $tpldir/module/module_template-0.0.1.tm r]; set filedata [read $fd]; close $fd - set filedata [string map [list %pkg% $modulename %year% $year %license% $opt_license] $filedata] - set modulefile $modulefolder/${moduletail}-$magicversion.tm - set fd [open $modulefile w] - fconfigure $fd -translation binary - puts -nonewline $fd $filedata - close $fd - - return [list file $modulefile version $opt_version] - } - - proc make {args} { - set startdir [pwd] - set project_base "" ;#empty for unknown - if {[punk::repo::is_git $startdir]} { - set project_base [punk::repo::find_git] - set sourcefolder $project_base/src - } elseif {[punk::repo::is_fossil $startdir]} { - set project_base [punk::repo::find_fossil] - set sourcefolder $project_base/src - } else { - if {[punk::repo::is_candidate $startdir]} { - set project_base [punk::repo::find_candidate] - set sourcefolder $project_base/src - puts stderr "WARNING - project not under git or fossil control" - puts stderr "Using base folder $project_base" - } else { - set sourcefolder $startdir - } - } - - #review - why can't we be anywhere in the project? - if {([file tail $sourcefolder] ne "src") || (![file exists $sourcefolder/make.tcl])} { - puts stderr "mix make must be run from src folder containing make.tcl - unable to proceed (cwd: [pwd])" - if {[string length $project_base]} { - if {[file exists $project_base/src] && [string tolower [pwd]] ne [string tolower $projectbase/src]} { - puts stderr "Try cd to $project_base/src" - } - } - return false - } - - if {![string length $project_base]} { - puts stderr "WARNING no git or fossil repository detected." - puts stderr "Using base folder $startdir" - set project_base $startdir - } - - set lc_this_exe [string tolower [info nameofexecutable]] - set lc_proj_bin [string tolower $project_base/bin] - set lc_build_bin [string tolower $project_base/src/_build] - - - set is_own_exe 0 - if {[string match "${lc_proj_bin}*" $lc_this_exe] || [string match "${lc_build_bin}" $lc_this_exe]} { - set is_own_exe 1 - puts stderr "WARNING - running make using executable that may be created by the project being built" - puts stdout "Do you want to proceed using this executable? (build will probably stop when it is unable to update the executable) Y|N" - set stdin_state [fconfigure stdin] - fconfigure stdin -blocking 1 - set answer [string tolower [gets stdin]] - fconfigure stdin -blocking [dict get $stdin_state -blocking] - if {$answer ne "y"} { - puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." - return - } - } - cd $sourcefolder - #use run so that stdout visible as it goes - set exitinfo [run [info nameofexecutable] $sourcefolder/make.tcl project] - set exitcode [dict get $exitinfo exitcode] - - cd $startdir - if {$exitcode != 0} { - puts stderr "FAILED with exitcode $exitcode" - return false - } else { - puts stdout "OK make finished " - return true - } - } - - proc Kettle {args} { - tailcall lib::kettle_call lib {*}$args - } - proc KettleShell {args} { - tailcall lib::kettle_call shell {*}$args - } - - #proc libexample {} { - # set result [lib::libfunc1 test] - # return $result - #} - - - namespace eval lib { - proc libfunc1 {args} { - return libfunc1-$args - } - proc module_types {} { - #first in list is default for unspecified -type when creating new module - return [list plain tarjar zipkit] - } - proc module_subpath {modulename} { - set modulename [string trim $modulename :] - set nsq [namespace qualifiers $modulename] - return [string map [list :: /] $nsq] - } - - #find src/something folders which are not certain known folders with other purposes, (such as: bootsupport .vfs folders or vendor folders etc) and contain .tm file(s) - proc find_source_module_paths {{path {}}} { - if {![string length [set candidate [punk::repo::find_candidate $path]]]} { - error "find_source_module_paths cannot determine a suitable project root at or above path '$path' - path supplied should be within a project" - } - #we can return module paths even if the project isn't yet under revision control - set src_subs [glob -nocomplain -dir [file join $candidate src] -type d -tail *] - set antipatterns [list *.vfs vendor* lib _build doc embedded runtime bootsupport] - set tm_folders [list] - foreach sub $src_subs { - set is_ok 1 - foreach anti $antipatterns { - if {[string match $anti $sub]} { - set is_ok 0 - break - } - } - if {!$is_ok} { - continue - } - set testfolder [file join $candidate src $sub] - set tmfiles [glob -nocomplain -dir $testfolder -type f -tail *.tm] - if {[llength $tmfiles]} { - lappend tm_folders $testfolder - } - } - return $tm_folders - } - proc validate_modulename {modulename {name_description modulename}} { - validate_name_not_empty_or_spaced $modulename $name_description - set testname [string map [list :: ""] $modulename] - if {[string first : $testname] >=0} { - error "$name_description '$modulename' can only contain paired colons" - } - set badchars [list - "$" "?" "*"] - foreach bc $badchars { - if {[string first $bc $modulename] >= 0} { - error "$name_description '$modulename' can not contain character '$bc'" - } - } - return $modulename - } - proc validate_projectname {projectname {name_description projectname}} { - validate_name_not_empty_or_spaced $projectname $name_description - set reserved_words [list etc lib bin modules src doc vendorlib vendormodules embedded runtime _aside _build] - if {$projectname in $reserved_words } { - error "$name_description '$projectname' cannot be one of reserved_words: $reserved_words" - } - if {[string first "::" $projectname] >= 0} { - error "$name_description '$projectname' cannot contain namespace separator '::'" - } - return $projectname - } - proc validate_name_not_empty_or_spaced {name {name_description name}} { - if {![string length $name]} { - error "$name_description cannot be empty" - } - if {[string length [string map [list " " "" \n "" \r "" \t ""] $name]] != [string length $name]} { - error "$name_description cannot contain whitespace" - } - return $name - } - proc get_build_cksums_stored {path} { - set buildfolder [get_build_folder $path] - - set vfscontainer [file dirname $buildfolder] - set vfslist [glob -nocomplain -dir $vfscontainer -type d -tail *.vfs] - set dict_cksums [dict create] - foreach vfs $vfslist { - set vname [file rootname $vfs] - set dict_vfs [list $vname.vfs "" $vname.exe "" buildruntime.exe ""] - set ckfile $buildfolder/$vname.cksums - if {[file exists $ckfile]} { - set data [punk::repo::fcat -translation binary $ckfile] - foreach ln [split $data \n] { - if {[string trim $ln] eq ""} {continue} - lassign $ln path cksum - dict set dict_vfs $path $cksum - } - } - dict set dict_cksums $vname $dict_vfs - } - return $dict_cksums - } - proc get_build_folder {path} { - if {[string length [set testbase [punk::repo::find_fossil $path]]]} { - set base $testbase - } elseif {[string length [set testbase [punk::repo::find_git $path]]]} { - set base $testbase - } elseif {[string length [set testbase [punk::repo::find_candidate $path]]]} { - set base $testbase - } else { - error "get_build_cksums_stored unable to determine project base for path '$path'" - } - if {![file exists $base/src] || ![file writable $base/src]} { - error "get_build_cksums_stored unable to access $base/src" - } - file mkdir $base/src/_build - return $base/src/_build - } - proc get_build_cksums {path} { - set buildfolder [get_build_folder $path] - set vfscontainer [file dirname $buildfolder] - set vfslist [glob -nocomplain -dir $vfscontainer -type d -tail *.vfs] - set buildruntime $buildfolder/buildruntime.exe - set ckinfo_buildruntime [punk::repo::cksum_path $buildruntime] - set dict_cksums [dict create] - foreach vfs $vfslist { - set vname [file rootname $vfs] - set ckinfo_vfs [punk::repo::cksum_path $vfscontainer/$vname.vfs] - set ckinfo_exe [punk::repo::cksum_path $buildfolder/$vname.exe] - set dict_vfs [list $vname.vfs [dict get $ckinfo_vfs cksum] $vname.exe [dict get $ckinfo_exe cksum] buildruntime.exe [dict get $ckinfo_buildruntime cksum]] - dict set dict_cksums $vname $dict_vfs - } - return $dict_cksums - } - proc mix_templates_dir {} { - set provide_statement [package ifneeded punk::mix [package require punk::mix]] - set tmdir [file dirname [lindex $provide_statement end]] - set tpldir $tmdir/mix/templates - if {![file exists $tpldir]} { - error "punk::mix::lib::mix_templates_dir unable to locate mix templates folder at '$tpldir'" - } - return $tpldir - } - - proc is_valid_tm_version {versionpart} { - #Needs to be suitable for use with Tcl's 'package vcompare' - if {![catch [list package vcompare $versionpart $versionpart]]} { - return 1 - } else { - return 0 - } - } - - #todo - review. Check Tcl's exact requirements here - # assume we can have things like: 1.1a2 2.2.b4 - proc is_valid_tm_version1 {versionpart} { - #review - regexp from https://wiki.tcl-lang.org/page/Package+MetaData+Fields - #page notes that 'valid version numbers can be decoded via the following.." - #regexp {([0-9]+)\.([0-9]+)\.?([ab])?\.?([0-9]*)} $ver => major minor maturity level - #but that doesn't rule out invalid version numbers being passed by this and causing issues with version comparisons, package loading etc. - - set versionsegments [split $versionpart .] - if {![string is integer -strict [lindex $versionsegments 0]]} { - return 0 - } - #rudimentary check on the tail.. - #reviewed briefly 2023-07 - need to support e.g 2.5.b.5 ? - #Note that package vcompare in tcl 8.7a5 doesn't support 2.5.b.5 - foreach tailpart [lrange $versionsegments 1 end] { - if {![string is integer -strict $tailpart]} { - #extremely loose check.. - #pass anything with an a or b for now.. - #review to see if tcl tm system allows semver style x.y.z-beta etc or if we should lock it down - #need to take into account how tcl compares/orders version numbers. - if {(![string first a $tailpart] >= 0) && (![string first b $tailpart] >=0)} { - return 0 - } - } - } - return 1 - } - - - #Note that semver only has a small overlap with tcl tm versions. - #todo - work out what overlap and whether it's even useful - #see also TIP #439: Semantic Versioning (tcl 9??) - proc semver {versionstring} { - set re {^(0|[1-9]\d*)\.(0|[1-9]\d*)\.(0|[1-9]\d*)(?:-((?:0|[1-9]\d*|\d*[a-zA-Z-][0-9a-zA-Z-]*)(?:\.(?:0|[1-9]\d*|\d*[a-zA-Z-][0-9a-zA-Z-]*))*))?(?:\+([0-9a-zA-Z-]+(?:\.[0-9a-zA-Z-]+)*))?$} - } - proc magic_tm_version {} { - return 999999.0a1.0 ;#deliberately large so given load-preference when testing - } - proc copy_modules_from_source_to_base {srcdir basedir args} { - set defaults [list -glob *.tm -antiglob_file [list "*[magic_tm_version]*"] ] - set opts [dict merge $defaults $args] - copy_files_from_source_to_target $srcdir $basedir {*}$opts - } - proc copy_nonmodules_from_source_to_base {srcdir basedir args} { - #set keys [dict keys $args] - set defaults [list -glob * -antiglob_file [list "*.tm" "*-buildversion.txt"]] - set opts [dict merge $defaults $args] - copy_files_from_source_to_target $srcdir $basedir {*}$opts - } - - ## unidirectional file transfer to possibly non empty folder - #default of -overwrite no-targets will only copy files that are missing at the target - # -overwrite newer-targets will copy files with older source timestamp over newer target timestamp and those missing at the target (a form of 'restore' operation) - # -overwrite older-targets will copy files with newer source timestamp over older target timestamp and those missing at the target - # -overwrite all-targets will copy regardless of timestamp at target - # review - what about slightly mismatched system clocks and mounted filesystems? caller responsibility to verify first? - # if timestamp exactly equal - should we check content-hash? This is presumably only likely to occur deliberately(maliciously?) - # e.g some process that digitally signs or otherwise modifies a file and preserves update timestmp? - # if such a content-mismatch - what default behaviour and what options would make sense? - # probably it's reasonable that only all-targets would overwrite such files. - # consider -source_fudge_seconds +-X ?, -source_override_timestamp ts ??? etc which only adjust timestamp for calculation purposes? Define a specific need/usecase when reviewing. - # - # valid filetypes for src tgt - # src dir tgt dir - # todo - review and consider enabling symlink src and dst - # no need for src file - as we use -glob with no glob characters to match one source file file - # no ability to target file with different name - keep it simpler and caller will have to use an intermediate folder/file if they need to rename something? - # - # todo - determine what happens if mismatch between file type of a src vs target e.g target has dir matching filename at source - # As function is named copy_files... we should only expect dirs to be created as necessary to hold files - # A pre-scan to determine no such conflict - before attempting to copy anything might provide the most integrity at slight cost in speed. - proc copy_files_from_source_to_target {srcdir tgtdir args} { - set antidir [list "#*" "_aside" ".git" ".fossil*"] ;#defaults - set defaults [list -subdirlist {} -glob * -antiglob_file [list "*[magic_tm_version]*" "*-buildversion.txt"] -antiglob_dir $antidir -overwrite no-targets] - set opts [dict merge $defaults $args] - if {([llength $args] %2) != 0} { - error "copy_files_from_source_to_target requires option-style arguments to be in pairs. Received args: $args" - } - foreach k [dict keys $args] { - if {$k ni [dict keys $defaults]} { - error "copy_files_from_source_to_target unrecognised option '$k' known options: '[dict keys $defaults]'" - } - } - - #The choice to recurse using the original values of srcdir & tgtdir, and passing the subpath down as a list in -subdirlist seems an odd one. - #(as opposed to a more 'standard' mechanism of adjusting srcdir & tgtdir as we move down the tree) - #It comes from build_modules_from_source_to_base where we need to keep track of position relative to our targetdir starting point to handle submodules e.g pkg::something::mypkg-0.1.tm - #It could have been handled with some other parameter such as -depth, but this -subdirlist mechanism, whilst perhaps not beautiful, is straightforward enough - #and may be less error prone than doing slightly more opaue path manipulations at each recursion level to determine where we started - #For consistency - we'll use the same mechanism in various recursive directory walking procedures such as this one. - set subdirlist [dict get $opts -subdirlist] - - set fileglob [dict get $opts -glob] - set antiglobs [dict get $opts -antiglob_file] - set known_whats [list no-targets newer-targets older-targets all-targets] - set overwrite_what [string tolower [dict get $opts -overwrite]]; #accept any case for value to allow emphasis by caller e.g -overwrite NEWER-TARGETS - if {$overwrite_what ni $known_whats} { - error "copy_files_from_source_to_target received unrecognised value for -overwrite. Received value '$overwrite_what' vs known values '$known_whats'" - } - set opt_antiglob_dir [dict get $opts -antiglob_dir] - - if {[llength $subdirlist] == 0} { - set current_source_dir $srcdir - set current_target_dir $tgtdir - } else { - set current_source_dir $srcdir/[file join {*}$subdirlist] - set current_target_dir $tgtdir/[file join {*}$subdirlist] - } - - if {$overwrite_what in [list newer-targets older-targets]} { - error "copy_files_from_source_to_target newer-target, older-targets not implemented - sorry" - #TODO - check crossplatform availability of ctime (on windows it still seems to be creation time, but on bsd/linux it's last attribute mod time) - # external pkg? use twapi and ctime only on other platforms? - } - - if {![file exists $current_source_dir]} { - error "copy_files_from_source_to_target current source dir:'$current_source_dir' doesn't exist (srcdir:$srcdir tgtdir:$tgtdir args:'$args')" - } - if {![file exists $current_target_dir]} { - error "copy_files_from_source_to_target current target dir:'$current_target_dir' doesn't exist (srcdir:$srcdir tgtdir:$tgtdir args:'$args')" - } - if {([file type $current_source_dir] ni [list directory]) || ([file type $current_target_dir] ni [list directory])} { - error "copy_files_from_source_to_target requires source and target dirs to be of type 'directory' type current source: [file type $current_source_dir] type current target: [file type $current_target_dir]" - } - - set copied_files [list] - set candidate_list [glob -nocomplain -dir $current_source_dir -type f -tail $fileglob] - set hidden_candidate_list [glob -nocomplain -dir $current_source_dir -types {hidden f} -tail $fileglob] - foreach h $hidden_candidate_list { - if {$h ni $candidate_list} { - lappend candidate_list $h - } - } - set match_list [list] - foreach m $candidate_list { - set suppress 0 - foreach anti $antiglobs { - if {[string match $anti $m]} { - puts stderr "anti: $anti vs m:$m" - set suppress 1 - break - } - } - if {$suppress == 0} { - lappend match_list $m - } - } - - - foreach m $match_list { - puts stdout "copying file $current_source_dir/$m to $current_target_dir" - if {$overwrite_what eq "all-targets"} { - file copy -force $current_source_dir/$m $current_target_dir - } else { - if {![file exists $current_target_dir/$m]} { - file copy $current_source_dir/$m $current_target_dir - } else { - puts stderr "Skipping file copy $m target $current_target_dir/$m already exists (use -overwrite all-targets to overwrite)" - #TODO! implement newer-targets older-targets - } - } - lappend copied_files $current_source_dir/$m - } - set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] - set hiddensubdirs [glob -nocomplain -dir $current_source_dir -type {hidden d} -tail *] - foreach h $hiddensubdirs { - if {$h in [list "." ".."]} { - continue - } - if {$h ni $subdirs} { - lappend subdirs $h - } - } - #puts stderr "subdirs: $subdirs" - foreach d $subdirs { - foreach dg $opt_antiglob_dir { - if {[string match $dg $d]} { - continue - } - } - if {![file exists $current_target_dir/$d]} { - file mkdir $current_target_dir/$d - } - lappend copied_files {*}[copy_files_from_source_to_target $srcdir $tgtdir -subdirlist [list {*}$subdirlist $d] -glob $fileglob -antiglob_file $antiglobs -antiglob_dir $opt_antiglob_dir -overwrite $overwrite_what] - } - return $copied_files - } - - proc build_modules_from_source_to_base {srcdir basedir args} { - set antidir [list "#*" "_aside" ".git" ".fossil*"] ;#exact or glob patterns for folders we don't want to search in. - set defaults [list -subdirlist {} -glob *.tm] - set opts [dict merge $defaults $args] - set subdirlist [dict get $opts -subdirlist] - set fileglob [dict get $opts -glob] - if {![string match "*.tm" $fileglob]} { - error "build_modules_from_source_to_base -glob '$fileglob' doesn't seem to target tcl modules." - } - - set magicversion [magic_tm_version] ;#deliberately large so given load-preference when testing - set module_list [list] - - if {[file tail [file dirname $srcdir]] ne "src"} { - puts stderr "ERROR build_modules_from_source_to_base can only be called with a srcdir that is a subfolder of your 'src' directory" - puts stderr "The .tm modules are namespaced based on their directory depth - so we need to start at the root" - puts stderr "To build a subtree of your modules - use an appropriate src/modules folder and pass in the -subdirlist." - puts stderr "e.g if your modules are based at /x/src/modules2 and you wish to build only the .tm files at /x/src/modules2/skunkworks/lib" - puts stderr "Use: >build_modules_from_source_to_base /x/src/modules2 /x/modules2 -subdirlist {skunkworks lib}" - exit 2 - } - set srcdirname [file tail $srcdir] - - set build [file dirname $srcdir]/_build/$srcdirname ;#relative to *original* srcdir - not current_source_dir - if {[llength $subdirlist] == 0} { - set target_module_dir $basedir - set current_source_dir $srcdir - } else { - set target_module_dir $basedir/[file join {*}$subdirlist] - set current_source_dir $srcdir/[file join {*}$subdirlist] - } - if {![file exists $target_module_dir]} { - error "build_modules_from_source_to_base from current source dir: '$current_source_dir'. Basedir:'$current_module_dir' doesn't exist or is empty" - } - if {![file exists $current_source_dir]} { - error "build_modules_from_source_to_base from current source dir:'$current_source_dir' doesn't exist or is empty" - } - - set src_modules [glob -nocomplain -dir $current_source_dir -type f -tail $fileglob] - - - foreach m $src_modules { - set fileparts [split [file rootname $m] -] - set tmfile_versionsegment [lindex $fileparts end] - if {$tmfile_versionsegment eq $magicversion} { - #rebuild the .tm from the #tarjar - set basename [join [lrange $fileparts 0 end-1] -] - set versionfile $current_source_dir/$basename-buildversion.txt - if {![file exists $versionfile]} { - puts stderr "WARNING: Missing buildversion text file: $versionfile" - puts stderr "Using version 0.1 - create $versionfile containing the desired version number as the top line to avoid this warning" - set module_build_version "0.1" - } else { - set fd [open $versionfile r]; set data [read $fd]; close $fd - set ln0 [lindex [split $data \n] 0] - set ln0 [string trim $ln0]; set ln0 [string trim $ln0 \r] - if {![is_valid_tm_version $ln0]} { - puts stderr "ERROR: build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file" - exit 3 - } - set module_build_version $ln0 - } - - - if {[file exists $current_source_dir/#tarjar-$basename-$magicversion]} { - file mkdir $buildfolder - - if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} { - - } else { - - } - #REVIEW - should be in same structure/depth as $target_module_dir in _build? - set tmfile $basedir/_build/$basename-$module_build_version.tm - file mkdir $basedir/_build - file delete -force $basedir/_build/#tarjar-$basename-$module_build_version - file delete -force $tmfile - - - file copy -force $current_source_dir/#tarjar-$basename-$magicversion $basedir/_build/#tarjar-$basename-$module_build_version - # - #bsdtar doesn't seem to work.. or I haven't worked out the right options? - #exec tar -cvf $basedir/_build/$basename-$module_build_version.tm $basedir/_build/#tarjar-$basename-$module_build_version - package require tar - tar::create $tmfile $basedir/_build/#tarjar-$basename-$module_build_version - if {![file exists $tmfile]} { - puts stdout "ERROR: Failed to build tarjar file $tmfile" - exit 4 - } - #copy the file? - #set target $target_module_dir/$basename-$module_build_version.tm - #file copy -force $tmfile $target - - lappend module_list $tmfile - } else { - #assume that either the .tm is not a tarjar - or the tarjar dir is capped (trailing #) and the .tm has been manually tarred. - if {[file exists $current_source_dir/#tarjar-$basename-${magicversion}#]} { - puts stderr "Warning: found 'capped' folder #tarjar-$basename-${magicversion}# - No attempt being made to update version in description.txt" - } - set target $target_module_dir/$basename-$module_build_version.tm - puts stdout "copying module $current_source_dir/$m to $target as version: $module_build_version ([file tail $target])" - set fd [open $current_source_dir/$m r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd - set data [string map [list $magicversion $module_build_version] $data] - set fdout [open $target w] - fconfigure $fdout -translation binary - puts -nonewline $fdout $data - close $fdout - #file copy -force $srcdir/$m $target - lappend module_list $target - } - - continue - } - - - if {![is_valid_tm_version $tmfile_versionsegment]} { - #last segment doesn't look even slightly versiony - fail. - puts stderr "ERROR: Unable to confirm file $current_source_dir/$m is a reasonably versioned .tm module - ABORTING." - exit 1 - } - puts stderr "copying already versioned module $current_source_dir/$m to $target_module_dir" - file copy -force $current_source_dir/$m $target_module_dir - lappend module_list $current_source_dir/$m - } - set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] - #puts stderr "subdirs: $subdirs" - foreach d $subdirs { - foreach dg $antidir { - if {[string match $dg $d]} { - continue - } - } - if {![file exists $target_module_dir/$d]} { - file mkdir $target_module_dir/$d - } - lappend module_list {*}[build_modules_from_source_to_base $srcdir $basedir -subdirlist [list {*}$subdirlist $d] -glob $fileglob] - } - return $module_list - } - - proc kettle_call {calltype args} { - if {$calltype ni [list lib shell]} { - error "pmix kettle_call 1st argument must be one of: 'lib' for direct use of kettle module or 'shell' to call as separate process" - } - if {$calltype eq "shell"} { - set kettleappfile [file dirname [info nameofexecutable]]/kettle - set kettlebatfile [file dirname [info nameofexecutable]]/kettle.bat - - if {(![file exists $kettleappfile]) && (![file exists $kettlebatfile])} { - error "pmix kettle_call unable to find installed kettle application file '$kettleappfile' (or '$kettlebatfile' if on windows)" - } - if {[file exists $kettleappfile]} { - set kettlescript $kettleappfile - } - if {$::tcl_platform(platform) eq "windows"} { - if {[file exists $kettlebatfile]} { - set kettlescript $kettlebatfile - } - } - } - set startdir [pwd] - if {![file exists $startdir/build.tcl]} { - error "pmix kettle must be run from a folder containing build.tcl (cwd: [pwd])" - } - if {[catch {package present kettle}]} { - puts stdout "Loading kettle package - may be delay on first load ..." - package require kettle - } - set first [lindex $args 0] - if {[string match @* $first]} { - error "pmix kettle doesn't support special operations - try calling tclsh kettle directly" - } - if {$first eq "-f"} { - set args [lassign $args __ path] - } else { - set path $startdir/build.tcl - } - set opts [list] - - if {[lindex $args 0] eq "-trace"} { - set args [lrange $args 1 end] - lappend opts --verbose on - } - set goals [list] - - if {$calltype eq "lib"} { - file mkdir ~/.kettle - set dotfile ~/.kettle/config - if {[file exists $dotfile] && - [file isfile $dotfile] && - [file readable $dotfile]} { - ::kettle io trace {Loading dotfile $dotfile ...} - set args [list {*}[::kettle path cat $dotfile] {*}$args] - } - } - - #hardcoded kettle option names (::kettle option names) - retrieved using kettle::option names - #This is done so we don't have to load kettle lib for shell call (both loading as module and running shell are annoyingly SLOW) - #REVIEW - needs to be updated to keep in sync with kettle. - set knownopts [list\ - --exec-prefix --bin-dir --lib-dir --prefix --man-dir --html-dir --markdown-dir --include-dir \ - --ignore-glob --dry --verbose --machine --color --state --config --with-shell --log \ - --log-append --log-mode --with-dia --constraints --file --limitconstraints --tmatch --notfile --single --valgrind --tskip --repeats \ - --iters --collate --match --rmatch --with-doc-destination --with-git --target --test-include \ - ] - - while {[llength $args]} { - set o [lindex $args 0] - switch -glob -- $o { - --* { - #instead of using: kettle option known - if {$o ni $knownopts} { - error "Unable to process unknown option $o." {} [list KETTLE (pmix)] - } - lappend opts $o [lindex $args 1] - #::kettle::option set $o [lindex $args 1] - set args [lrange $args 2 end] - } - default { - lappend goals $o - set args [lrange $args 1 end] - } - } - } - - if {![llength $goals]} { - lappend goals help - } - if {"--prefix" ni [dict keys $opts]} { - dict set opts --prefix [file dirname $startdir] - } - if {$calltype eq "lib"} { - ::kettle status clear - ::kettle::option::set @kettle $startdir - foreach {o v} $opts { - ::kettle option set $o $v - } - ::kettle option set @srcscript $path - ::kettle option set @srcdir [file dirname $path] - ::kettle option set @goals $goals - ::source $path - puts stderr "recipes: [::kettle recipe names]" - ::kettle recipe run {*}[::kettle option get @goals] - - set state [::kettle option get --state] - if {$state ne {}} { - puts stderr "saving kettle state: $state" - ::kettle status save $state - } - - } else { - #shell - puts stdout "Running external kettle process with args: $opts $goals" - run -n tclsh $kettlescript -f $path {*}$opts {*}$goals - } - - } - - } +namespace eval punk::mix { + } +package provide punk::mix [namespace eval punk::mix { + variable version + set version 0.2 -namespace eval punk::mix::cli { - variable default_command help - package require punk::mix::base - package require punk::overlay - punk::overlay::custom_from_base [namespace current] ::punk::mix::base -} - +}] diff --git a/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/bootsupport/modules/punk/repo-0.1.1.tm index bc218fca..4938962a 100644 --- a/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -767,6 +767,30 @@ namespace eval punk::repo { return $root_dict } + proc fossil_get_repository_file {{path {}}} { + if {$path eq {}} { set path [pwd] } + set fossilcmd [auto_execok fossil] + if {[llength $fossilcmd]} { + do_in_path $path { + set fossilinfo [::exec {*}$fossilcmd info] + } + set matching_lines [punk::repo::grep {repository:*} $fossilinfo] + if {![llength $matching_lines]} { + return "" + } + set trimmedline [string trim [lindex $matching_lines 0]] + set firstcolon [string first : $trimmedline] + set repofile_path [string trim [string range $trimmedline $firstcolon+1 end]] + if {![file exists $repofile_path]} { + puts stderr "Repository file pointed to by fossil configdb doesn't exist: $repofile_path" + return "" + } + return $repofile_path + } else { + puts stderr "fossil_get_repository_file: fossil command unavailable" + return "" + } + } proc fossil_get_repository_folder_for_project {projectname args} { set defaults [list -parentfolder \uFFFF -extrachoice \uFFFF] @@ -1040,7 +1064,7 @@ namespace eval punk::repo { do_in_path $path { set info [::exec {*}$fossilcmd remote ls] } - return [string trim $v] + return [string trim $info] } else { return Unknown } diff --git a/src/bootsupport/modules/punk/winpath-0.1.0.tm b/src/bootsupport/modules/punk/winpath-0.1.0.tm index e60648b0..a21e91ef 100644 --- a/src/bootsupport/modules/punk/winpath-0.1.0.tm +++ b/src/bootsupport/modules/punk/winpath-0.1.0.tm @@ -25,111 +25,18 @@ namespace eval punk::winpath { namespace export winpath windir cdwin cdwindir illegalname_fix illegalname_test - #review - is this intended to be useful/callable on non-windows platforms? - #it should in theory be useable from another platform that wants to create a path for use on windows. - #In this case - we shouldn't examine what volumes exist (assume A: .. Z: are valid) - #review zipfs:// other uri schemes? - proc winpath {path} { - #NOTE: tcl file exists gives different answers on windows for paths like /c depending on cwd (presumably based on file pathtype of volumerelative) - #This is add odds with attempting to navigate on a windows system which has cygwin, wsl etc... It also makes it difficult for functions intended to operate independent of CWD. - #e.g there is potential confusion when there is a c folder on c: drive (c:/c) - #I will attempt to provide a coherent operation for winpath ./ ../ etc , but it may disallow for example; change to /something or /x where these don't match a driveletter or /mnt - #whereas tcl may allow cd to /something if a something folder happens to exist on the current volume based on cwd. - #I think it's preferable to require an explicit driveletter /x or /mnt when using unix-like paths on windows - but practical considerations may prove me wrong.. - #It's possible that this function should also ignore the current set of driveletters - and operate completely independent of whether a path actually exists - #This makes it hard to use things like 'file normalize' - which also looks at things like current volume. - # - #Note for example the results of 'which' grep on windows can produce a path like /c/Users/somewhere/bin/grep - #which tcl's file normalize may change to C:/c/Users or X:/c/Users - based on current volumen. Given that C:/c might exist - this can be problematic in a couple of ways. - #The mixing of unix-like and windows commands on the same machine is a large part of the problem.. but this mix is now common - # - #convert /c/etc to C:/etc - set re_slash_x_slash {^/([[:alpha:]]){1}/.*} - set re_slash_else {^/([[:alpha:]]*)(.*)} - set volumes [file volumes] - #exclude things like //zipfs:/ - set driveletters [list] - foreach v $volumes { - if {[regexp {^([[:alpha:]]){1}:/$} $v _ letter]} { - lappend driveletters $letter - } - } - #puts stderr "->$driveletters" - - if {[regexp $re_slash_x_slash $path _ letter]} { - #upper case appears to be windows canonical form - set path [string toupper $letter]:/[string range $path 3 end] - } elseif {[regexp {^/mnt/([[:alpha:]]){1}/.*} [string tolower $path] _ letter]} { - set path [string toupper $letter]:/[string range $path 7 end] - } elseif {[regexp {^/mnt/([[:alpha:]]){1}$} [string tolower $path] _ letter]} { - set path [string toupper $letter]:/ - } elseif {[regexp $re_slash_else $path _ firstpart remainder]} { - #could be for example /c or /something/users - if {[string length $firstpart] == 1} { - set letter $firstpart - set path [string toupper $letter]:/ - } else { - #attempt to use cygpath helper - if {![catch { - set cygpath [runout -n cygpath -w $path] ;#! - set ::punk::last_run_display [list] ;#hack - review shouldn't really be necessary.. but because we call winpath from ./ - the repl looks for last_run_display - } errM]} { - set path [string map [list "\\" "/"] $cygpath] - } else { - error "Path '$path' does not appear to be in a standard form. For unix-like paths on windows such as /x, x must correspond to a drive letter. Consider installing cygwin's cygpath tool to see if that helps." - } - } - } - #puts stderr "=> $path" - #things like 'which' seem to return a path minus the .exe - so we'll just test the containing folder - # - #By now file normalize shouldn't do too many shannanigans related to cwd.. - #We want it to look at cwd for relative paths.. but we don't consider things like /c/Users to be relative even on windows - if {![file exists [file dirname $path]]} { - set path [file normalize $path] - #may still not exist.. that's ok. - } - #file normalize may change backslashes to forward slashes.. including things like the special \\?\ prefix which is intended to stop windows api from parsing a name - #2023 - this is ok as //?/ also seems to work.. but it is unclear if that is because Tcl is re-converting to backslashes - if {[illegalname_test $path]} { - set path [illegalname_fix $path] - } - return $path - } - proc windir {path} { - if {$path eq "~"} { - #as the tilde hasn't been normalized.. we can't assume we're running on the actual platform - return ~/.. - } - return [file dirname [winpath $path]] - } - - #REVIEW high-coupling - proc cdwin {path} { - set path [winpath $path] - if {$::repl::running} { - repl::term::set_console_title $path - } - cd $path - } - proc cdwindir {path} { - set path [winpath $path] - if {$::repl::running} { - repl::term::set_console_title $path - } - cd [file dirname $path] - } #\\servername\share etc or \\?\UNC\servername\share etc. proc is_unc_path {path} { - set path [string map [list \\ /] $path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway) - if {[string first "//" $path] == 0} { + set strcopy_path [punk::objclone $path] + set strcopy_path [string map [list \\ /] $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway) + if {[string first "//" $strcopy_path] == 0} { #check for "Dos device path" syntax - if {[string range $path 0 3] in [list "//?/" "//./"]} { + if {[string range $strcopy_path 0 3] in [list "//?/" "//./"]} { #Note that //./ doesn't appear to be supported in Tcl as at 2023-08 - but //?/ works (except for //?/UNC/Server/share) - if {[string range $path 4 6] eq "UNC"} { + if {[string range $strcopy_path 4 6] eq "UNC"} { return 1 } else { #some other Dos device path. Could be a drive which is mapped to a UNC path - but the path itself isn't a unc path @@ -146,7 +53,7 @@ namespace eval punk::winpath { #ordinary \\Servername or \\servername\share or \\servername\share\path (or forward-slash equivalent) with no dos device syntax //?/ //./ etc. proc is_unc_path_plain {path} { if {[is_unc_path $path]} { - if {![is_dos_device_path]} { + if {![is_dos_device_path $path]} { return 1 } else { return 0 @@ -156,9 +63,9 @@ namespace eval punk::winpath { } } - #'file attributes', and therefor this operation, is expensive (on windows at least) + #int-rep path preserved - but 'file attributes', and therefor this operation, is expensive (on windows at least) proc pwdshortname {{path {}}} { - if {![string length $path]} { + if {$path eq ""} { set path [pwd] } else { if {[file pathtype $path] eq "relative"} { @@ -170,8 +77,9 @@ namespace eval punk::winpath { #dos device path syntax allows windows api to acces extended-length paths and filenames with illegal path characters such as trailing dots or whitespace #(can exist on server shares and on NTFS - but standard apps can't access without dos device syntax) proc is_dos_device_path {path} { - set path [string map [list \\ /] $path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway) - if {[string range $path 0 3] in [list "//?/" "//./"]} { + set strcopy_path [punk::objclone $path] + set strcopy_path [string map [list \\ /] $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway) + if {[string range $strcopy_path 0 3] in [list "//?/" "//./"]} { return 1 } else { return 0 @@ -192,17 +100,35 @@ namespace eval punk::winpath { proc strip_unc_path_prefix {path} { if {[is_unc_path $path]} { #//?/UNC/server/etc - return [string range $path 7 end] + set strcopy_path [punk::objclone $path] + set trimmedpath [string range $strcopy_path 7 end] + file pathtype $trimmedpath ;#shimmer it to path rep + return $trimmedpath } elseif {is_unc_path_plain $path} { #plain unc //server - return [string range $path 2 end] + set strcopy_path [punk::objclone $path] + set trimmedpath [string range $strcopy_path 2 end] + file pathtype $trimmedpath + return $trimmedpath } else { return $path } } #we don't validate that path is actually illegal because we don't know the full range of such names. #The caller can apply this to any path. - #don't test for platform here - needs to be callable from any platform for potential passing to windows + #don't test for platform here - needs to be callable from any platform for potential passing to windows (what usecase? 8.3 name is not always calculable independently) + #The utility of this is questionable. prepending a dos-device path won't make a filename with illegal characters readable by windows. + #It will need the 'shortname' at least for the illegal segment - if not the whole path + #Whilst the 8.3 name algorithm - including undocumented hash function has been reverse engineered + #- it depends on the content of the directory - as collisions cause a different name (e.g incremented number) + #- it also depends on the history of the folder + #- you can't take the current dir contents and a particular *existing* longname and determine the shortname algorithmically... + #- the shortname may have been generated during a different directory state. + #- It is then stored on disk (where?) - so access to reading the existing shortname is required. + #- An implementation of the 8.3 algorithm would only be potentially useful in determining the name that will result from adding a new file + # and would be subject to potential collisions if there are race-conditions in file creation + #- Using an 8.3 algorithm externally would be dangerous in that it could appear to work a lot of the time - but return a different file entirely sometimes. + #- Conclusion is that the 8.3 name must be retrieved rathern than calclated proc illegalname_fix {path} { #don't add extra dos device path syntax protection-prefix if already done if {[is_unc_path $path]} { @@ -214,6 +140,7 @@ namespace eval punk::winpath { } + #\\servername\share theoretically maps to: \\?\UNC\servername\share in protected form. https://learn.microsoft.com/en-us/dotnet/standard/io/file-path-formats #NOTE: 2023-08 on windows 10 at least \\?\UNC\Server\share doesn't work - ie we can't use illegalname_fix on UNC paths such as \\Server\share #(but mapped drive to same path will work) @@ -225,6 +152,10 @@ namespace eval punk::winpath { append err \n " - because //?/UNC/Servername/share is not supported in Tcl (and only minimally even in powershell) as at 2023. (on windows use mapped drive instead)" error $err } + + set strcopy_path [punk::objclone $path] + + #Note: path could still have leading double slash if it is a Dos device path: e.g. //?/c:/etc if {[file pathtype $path] eq "absolute"} { if {$path eq "~"} { @@ -239,10 +170,10 @@ namespace eval punk::winpath { } else { #set fullpath [file normalize $path] ;#very slow on windows #set fullpath [pwd]/$path ;#will keep ./ in middle of path - not valid for dos-device paths - if {[string range $path 0 1] eq "./"} { - set path [string range $path 2 end] + if {[string range $strcopy_path 0 1] eq "./"} { + set strcopy_path [string range $strcopy_path 2 end] } - set fullpath [file join [pwd] $path] + set fullpath [file join [pwd] $strcopy_path] } #For file I/O, the "\\?\" prefix to a path string tells the Windows APIs to disable all string parsing # and to send the string that follows it straight to the file system. @@ -252,16 +183,21 @@ namespace eval punk::winpath { #choose //?/ as normalized version - since likely 'file normalize' will do it anyway, and experimentall, the windows API accepts both REVIEW - return ${protect2}$fullpath + set result ${protect2}$fullpath + file pathtype $result ;#make it return a path rep + return $result } #don't test for platform here - needs to be callable from any platform for potential passing to windows #we can create files with windows illegal names by using //?/ dos device path syntax - but we need to detect when that is required. + # + # path int-rep preserving proc illegalname_test {path} { - #first test if already protected - we return false even if the file would be illegal without the protection! - if {[is_dos_device_path $path]} { - return 0 - } + #https://learn.microsoft.com/en-us/windows/win32/fileio/naming-a-file + #according to the above: Use any character in the current code page for a name, including Unicode characters and characters in the extended character set (128–255), except for the following: + set reserved [list < > : \" / \\ | ? *] + + #we need to exclude things like path/.. path/. foreach seg [file split $path] { if {$seg in [list . ..]} { @@ -289,14 +225,23 @@ namespace eval punk::winpath { return 0 } + proc test_ntfs_tunneling {f1 f2 args} { + file mkdir $f1 + puts stderr "waiting 15secs..." + after 5000 {puts -nonewline stderr .} + after 5000 {puts -nonewline stderr .} + after 5000 {puts -nonewline stderr .} + after 500 {puts stderr \n} + file mkdir $f2 + puts stdout "$f1 [file stat $f1]" + puts stdout "$f2 [file stat $f2]" + file delete $f1 + puts stdout "renaming $f2 to $f1" + file rename $f2 $f1 + puts stdout "$f1 [file stat $f1]" + + } - #---------------------------------------------- - #leave the winpath related aliases available on all platforms - interp alias {} cdwin {} punk::winpath::cdwin - interp alias {} cdwindir {} punk::winpath::cdwindir - interp alias {} winpath {} punk::winpath::winpath - interp alias {} windir {} punk::winpath::windir - #---------------------------------------------- } diff --git a/src/bootsupport/modules/punkcheck-0.1.0.tm b/src/bootsupport/modules/punkcheck-0.1.0.tm new file mode 100644 index 00000000..41d8759a --- /dev/null +++ b/src/bootsupport/modules/punkcheck-0.1.0.tm @@ -0,0 +1,1984 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application punkcheck 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + +package require punk::tdl +package require punk::repo +package require punk::mix::util + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Punkcheck uses the TDL format which is a list of lists in Tcl format +# It is intended primarily for source build/distribution tracking within a punk project or single filesystem - with relative paths. +# +#see following article regarding the many problems with using mtime for build-decisions: https://apenwarr.ca/log/20181113 +# +namespace eval punkcheck { + namespace export\ + uuid\ + start_installer_event installfile_* + + variable default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"] + variable default_antiglob_file_core "" + proc uuid {} { + set has_twapi 0 + if {"windows" eq $::tcl_platform(platform)} { + if {![catch {package require twapi}]} { + set has_twapi 1 + } + } + if {!$has_twapi} { + if {[catch {package require uuid} errM]} { + error "Unable to load a package for uuid on this platform. Try tcllib's uuid (any platform) - twapi for windows" + } + return [uuid::uuid generate] + } else { + return [twapi::new_uuid] + } + } + + proc default_antiglob_dir_core {} { + variable default_antiglob_dir_core + return $default_antiglob_dir_core + } + proc default_antiglob_file_core {} { + variable default_antiglob_file_core + if {$default_antiglob_file_core eq ""} { + set default_antiglob_file_core [list "*.swp" "*[punk::mix::util::magic_tm_version]*" "*-buildversion.txt" ".punkcheck"] + } + return $default_antiglob_file_core + } + + + proc load_records_from_file {punkcheck_file} { + set record_list [list] + if {[file exists $punkcheck_file]} { + set tdlscript [punk::mix::util::fcat $punkcheck_file] + set record_list [punk::tdl::prettyparse $tdlscript] + } + return $record_list + } + proc save_records_to_file {recordlist punkcheck_file} { + set newtdl [punk::tdl::prettyprint $recordlist] + set linecount [llength [split $newtdl \n]] + #puts stdout $newtdl + set fd [open $punkcheck_file w] + fconfigure $fd -translation binary + puts -nonewline $fd $newtdl + close $fd + return [list recordcount [llength $recordlist] linecount $linecount] + } + + + #todo - work out way to use same punkcheck file for multiple installers running concurrently. Thread? + #an installtrack objects represents an installation path from sourceroot to targetroot + #The source and target folders should be as specific as possible but it is valid to specify for example c:/ -> c:/ (or / -> /) if source and targets within the installation operation are spread around. + # + set objname [namespace current]::installtrack + if {$objname ni [info commands $objname]} { + package require oolib + + #FILEINFO record - target fileset with body records: INSTALL-RECORD,INSTALL-INPROGRESS,INSTALL-SKIPPED,DELETE-RECORD,DELETE-INPROGRESS,MODIFY-INPROGRESS,MODIFY-RECORD + #each FILEINFO body being a list of SOURCE records + oo::class create targetset { + variable o_targets + variable o_keep_installrecords + variable o_keep_skipped + variable o_keep_inprogress + variable o_records + constructor {args} { + #set o_records [oolib::collection create [namespace current]::recordcollection] + set o_records [list] + + } + + method as_record {} { + + set fields [list\ + -targets $o_targets\ + -keep_installrecords $o_keep_installrecords\ + -keep_skipped $o_keep_skipped\ + -keep_inprogress $o_keep_inprogress\ + body $o_records\ + ] + + set record [dict create tag FILEINFO {*}$fields] + } + + #retrieve last completed record for the fileset ie exclude SKIPPED,INSTALL-INPROGRESS,DELETE-INPROGRESS,MODIFY-INPROGRESS + method get_last_record {fileset_record} { + set body [dict_getwithdefault $fileset_record body [list]] + set previous_records [lrange $body 0 end-1] + #get last previous that is tagged INSTALL-RECORD,MODIFY-RECORD,DELETE-RECORD + set revlist [lreverse $previous_records] + foreach rec $revlist { + if {[dict get $rec tag] in [list "INSTALL-RECORD" "MODIFY-RECORD" "DELETE-RECORD" "VIRTUAL-RECORD"]} { + return $rec + } + } + return [list] + } + } + + oo::class create installevent { + variable o_id + variable o_rel_sourceroot + variable o_rel_targetroot + variable o_ts_begin + variable o_ts_end + variable o_types + variable o_configdict + variable o_targets + variable o_operation + variable o_operation_start_ts + variable o_fileset_record + variable o_installer ;#parent object + constructor {installer rel_sourceroot rel_targetroot args} { + set o_installer $installer + set o_operation_start_ts "" + set o_operation "" + set defaults [dict create\ + -id ""\ + -tsbegin ""\ + -config [list]\ + -tsend ""\ + -types [list]\ + ] + set opts [dict merge $defaults $args] + if {[dict get $opts -id] eq ""} { + set o_id [punkcheck::uuid] + } else { + set o_id [dict get $opts -id] + } + if {[dict get $opts -tsbegin] eq ""} { + set o_ts_begin [clock microseconds] + } else { + set o_ts_begin [dict get $opts -tsbegin] + } + set o_ts_end [dict get $opts -tsend] + set o_types [dict get $opts -types] + set o_configdict [dict get $opts -config] + + set o_rel_sourceroot $rel_sourceroot + set o_rel_targetroot $rel_targetroot + } + destructor { + #puts "[self] destructor called" + } + method as_record {} { + set begin_seconds [expr {$o_ts_begin / 1000000}] + set tsiso_begin [clock format $begin_seconds -format "%Y-%m-%dT%H:%M:%S"] + if {$o_ts_end ne ""} { + set end_seconds [expr {$o_ts_end / 1000000}] + set tsiso_end [clock format $end_seconds -format "%Y-%m-%dT%H:%M:%S"] + } else { + set tsiso_end "" + } + set fields [list\ + -tsiso_begin $tsiso_begin\ + -ts_begin $o_ts_begin\ + -tsiso_end $tsiso_end\ + -ts_end $o_ts_end\ + -id $o_id\ + -source $o_rel_sourceroot\ + -targets $o_rel_targetroot\ + -types $o_types\ + -config $o_configdict\ + ] + + set record [dict create tag EVENT {*}$fields] + } + method get_id {} { + return $o_id + } + method get_operation {} { + return $o_operation + } + method get_targets {} { + return $o_targets + } + method get_targets_exist {} { + set punkcheck_folder [file dirname [$o_installer get_checkfile]] + set existing [list] + foreach t $o_targets { + if {[file exists [file join $punkcheck_folder $t]]} { + lappend existing $t + } + } + return $existing + } + method end {} { + set o_ts_end [clock microseconds] + } + method targetset_dict {} { + punk::records_as_target_dict [$o_installer get_recordlist] + } + + #related - installfile_begin + #call init before we know if we are going to run the operation vs skip + method targetset_init {operation targetset} { + set known_ops [list QUERY INSTALL MODIFY DELETE VIRTUAL] + if {[string toupper $operation] ni $known_ops} { + error "[self] add_target unknown operation '$operation'. Known operations $known_ops" + } + set o_operation [string toupper $operation] + + if {$o_operation_start_ts ne ""} { + error "[self] targetset_tart $o_operation operation already in progress. Use targetset_finished or targetset_complete to finish." + } + set o_operation_start_ts [clock microseconds] + set seconds [expr {$o_operation_start_ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] + + set relativepath_targetset [list] + if {$o_operation eq "VIRTUAL"} { + foreach p $targetset { + lappend relativepath_targetset $p + } + } else { + foreach p $targetset { + if {[file pathtype $p] eq "absolute"} { + lappend relativepath_targetset [punkcheck::lib::path_relative $punkcheck_folder $p] + } else { + lappend relativepath_targetset $p + } + } + } + + + set fields [list\ + -tsiso $tsiso\ + -ts $o_operation_start_ts\ + -installer [$o_installer get_name]\ + -eventid $o_id\ + ] + + set o_targets [lsort -dictionary -increasing $relativepath_targetset] ;#exact sort order not critical - but must be consistent + + #set targetdict [my targetset_dict] + + set record_list [punkcheck::load_records_from_file $punkcheck_file] + set extractioninfo [punkcheck::recordlist::extract_or_create_fileset_record $o_targets $record_list] + set o_fileset_record [dict get $extractioninfo record] + set record_list [dict get $extractioninfo recordset] + set isnew [dict get $extractioninfo isnew] + set oldposition [dict get $extractioninfo oldposition] + unset extractioninfo + + #INSTALL-INPROGRESS will become INSTALL-RECORD or INSTALL-FAILED or INSTALL-SKIPPED upon finalisation + #-installer and -eventid keys are added here + set new_inprogress_record [dict create tag [string toupper $operation]-INPROGRESS {*}$fields -tempcontext [my as_record] body {}] + #set existing_body [dict_getwithdefault $o_fileset_record body [list]] + #todo - look for existing "-INPROGRESS" records - mark as failed or incomplete? + dict lappend o_fileset_record body $new_inprogress_record + + if {$isnew} { + lappend record_list $o_fileset_record + } else { + set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record] + } + if {$o_operation ne "QUERY"} { + punkcheck::save_records_to_file $record_list $punkcheck_file + } + return $o_fileset_record + + } + #operation has been started + #todo - upgrade .punkcheck format to hold more than just list of SOURCE entries in each record. + # - allow arbitrary targetset_startphase targetset_endphase calls to store timestamps and calculate elapsed time + method targetset_started {} { + set punkcheck_folder [file dirname [$o_installer get_checkfile]] + if {$o_operation eq "QUERY"} { + set fileinfo_body [dict get $o_fileset_record body] ;#body of FILEINFO record + set installing_record [lindex $fileinfo_body end] + + set ts_start [dict get $installing_record -ts] + set ts_now [clock microseconds] + set metadata_us [expr {$ts_now - $ts_start}] + + dict set installing_record -metadata_us $metadata_us + dict set installing_record -ts_start_transfer $ts_now + + lset fileinfo_body end $installing_record + + return [dict set o_fileset_record body $fileinfo_body] + } else { + #legacy call + #saves to .punkcheck file + return [set o_fileset_record [punkcheck::installfile_started_install $punkcheck_folder $o_fileset_record]] + } + } + method targetset_end {status args} { + set defaults [dict create\ + -note \uFFFF\ + ] + set known_opts [dict keys $defaults] + if {[llength $args] % 2 != 0} { + error "targetset_end arguments after status must be in the form of -flag value pairs. known flags: $known_opts" + } + set opts [dict merge $defaults $args] + if {[dict get $opts -note] eq "\uFFFF"} { + dict unset opts -note + } + + set status [string toupper $status] + set statusdict [dict create OK RECORD SKIPPED SKIPPED FAILED FAILED] + if {$o_operation_start_ts eq ""} { + error "[self] targetset_end $status - no current operation - call targetset_started first" + } + if {$status ni [dict keys $statusdict]} { + error "[self] targetset_end unrecognized status:$status known values: [dict keys $statusdict]" + } + if {![punkcheck::lib::is_file_record_inprogress $o_fileset_record]} { + error "targetset_end $status error: bad fileset_record - expected FILEINFO with last body element *-INPROGRESS" + } + set targetlist [dict get $o_fileset_record -targets] + if {$targetlist ne $o_targets} { + error "targetset_end $status error. targetlist mismatch between file : $targetlist vs $o_targets" + } + set operation_end_ts [clock microseconds] + set elapsed_us [expr {$operation_end_ts - $o_operation_start_ts}] + set file_record_body [dict get $o_fileset_record body] + set installing_record [lindex $file_record_body end] + set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] + set record_list [punkcheck::load_records_from_file $punkcheck_file] + if {[dict exists $installing_record -ts_start_transfer]} { + set ts_start_transfer [dict get $installing_record -ts_start_transfer] + set transfer_us [expr {$operation_end_ts - $ts_start_transfer}] + dict set installing_record -transfer_us $transfer_us + } + if {[dict exists $opts -note]} { + dict set installing_record -note [dict get $opts -note] + } + + dict set installing_record -elapsed_us $elapsed_us + dict unset installing_record -tempcontext + dict set installing_record tag "${o_operation}-[dict get $statusdict $status]" ;# e.g INSTALL-RECORD, INSTALL-SKIPPED + if {$o_operation in [list INSTALL MODIFY] && [dict get $statusdict $status] eq "RECORD"} { + #only calculate and store post operation target cksums on successful INSTALL or MODIFY, doesn't make sense for DELETE or VIRTUAL operations + set new_targets_cksums [list] ;#ordered list of cksums matching targetset order + set cksum_all_opts "" ;#same cksum opts for each target so we store it once + set ts_begin_cksum [clock microseconds] + foreach p $o_targets { + set tgt_cksum_info [punk::mix::base::lib::cksum_path [file join $punkcheck_folder $p]] + lappend new_targets_cksums [dict get $tgt_cksum_info cksum] + if {$cksum_all_opts eq ""} { + set cksum_all_opts [dict get $tgt_cksum_info opts] + } + } + set cksum_us [expr {[clock microseconds] - $ts_begin_cksum}] + dict set installing_record -targets_cksums $new_targets_cksums + dict set installing_record -cksum_all_opts $cksum_all_opts + dict set installing_record -cksum_us $cksum_us + } + lset file_record_body end $installing_record + dict set o_fileset_record body $file_record_body + set o_fileset_record [punkcheck::recordlist::file_record_prune $o_fileset_record] + + set oldrecordinfo [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $oldrecordinfo position] + if {$old_posn == -1} { + lappend record_list $o_fileset_record + } else { + lset record_list $old_posn $o_fileset_record + } + if {$o_operation ne "QUERY"} { + punkcheck::save_records_to_file $record_list $punkcheck_file + } + set o_operation_start_ts "" + set o_operation "" + return $o_fileset_record + } + method targetset_addsource {source_path} { + set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] + if {[file pathtype $source_path] eq "absolute"} { + set rel_source_path [punkcheck::lib::path_relative $punkcheck_folder $source_path] + } else { + set rel_source_path $source_path + } + + set o_fileset_record [punkcheck::installfile_add_source_and_fetch_metadata $punkcheck_folder $rel_source_path $o_fileset_record] + + } + method targetset_last_complete {} { + #retrieve last completed record for the fileset ie exclude SKIPPED,INSTALL-INPROGRESS,DELETE-INPROGRESS,MODIFY-INPROGRESS + set body [punkcheck::dict_getwithdefault $o_fileset_record body [list]] + set previous_records [lrange $body 0 end] + #get last that is tagged INSTALL-RECORD,MODIFY-RECORD,DELETE-RECORD + set revlist [lreverse $previous_records] + foreach rec $revlist { + if {[dict get $rec tag] in [list "INSTALL-RECORD" "MODIFY-RECORD" "DELETE-RECORD" "VIRTUAL-RECORD"]} { + return $rec + } + } + return [list] + + } + method targetset_source_changes {} { + punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $o_fileset_record body] end] + } + + } + + + oo::class create installtrack { + variable o_name + variable o_tsiso + variable o_ts + variable o_keep_events + variable o_checkfile + variable o_sourceroot + variable o_rel_sourceroot + variable o_targetroot + variable o_rel_targetroot + variable o_record_list + variable o_active_event + variable o_events + constructor {installername punkcheck_file} { + set o_active_event "" + set o_name $installername + + set o_checkfile [file normalize $punkcheck_file] + set o_sourceroot "" + set o_targetroot "" + set o_rel_sourceroot "" + set o_rel_targetroot "" + #todo - validate punkcheck file location further?? + set punkcheck_folder [file dirname $o_checkfile] + if {![file isdirectory $punkcheck_folder]} { + error "[self] constructor error. Folder for punkcheck_file not found - $o_checkfile" + } + + my load_all_records + set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] + set existing_header_posn [dict get $resultinfo position] + if {$existing_header_posn == -1} { + set this_installer_record [punkcheck::recordlist::new_installer_record $o_name] + set o_record_list [linsert $o_record_list 0 $this_installer_record] + } else { + set this_installer_record [dict get $resultinfo record] + } + set o_tsiso [dict get $this_installer_record -tsiso] + set o_ts [dict get $this_installer_record -ts] + set o_keep_events [dict get $this_installer_record -keep_events] + + set o_events [oolib::collection create [namespace current]::eventcollection] + set eventlist [punkcheck::dict_getwithdefault $this_installer_record body [list]] + foreach e $eventlist { + set eobj [punkcheck::installevent create [namespace current]::event_[my events count] [self] [dict get $e -source] [dict get $e -targets] {*}$e] + #$o_events add $e [dict get $e -id] + $o_events add $eobj [dict get $e -id] + } + + } + destructor { + #puts "[self] destructor called" + } + method test {} { + return [self] + } + method get_name {} { + return $o_name + } + method get_checkfile {} { + return $o_checkfile + } + + #call set_source_target before calling start_event/end_event + #each event can have different source->target pairs - but may often have same, so set on installtrack as defaults. Only persisted in event records. + method set_source_target {sourceroot targetroot} { + if {[file pathtype $sourceroot] ne "absolute"} { + error "[self] set_source_target error: sourceroot must be absolute path. Received '$sourceroot'" + } + if {[file pathtype $targetroot] ne "absolute"} { + error "[self] set_source_target error: targetroot must be absolute path. Received '$targetroot'" + } + set punkcheck_folder [file dirname $o_checkfile] + set o_sourceroot $sourceroot + set o_targetroot $targetroot + set o_rel_sourceroot [punkcheck::lib::path_relative $punkcheck_folder $sourceroot] + set o_rel_targetroot [punkcheck::lib::path_relative $punkcheck_folder $targetroot] + return [list $o_rel_sourceroot $o_rel_targetroot] + } + #review/fix to allow multiple installtrack objects on same punkcheck file. + method load_all_records {} { + set o_record_list [punkcheck::load_records_from_file $o_checkfile] + } + + #does not include associated FILEINFO records - as a targetset (FILEINFO record) can be associated with events from multiple installers over time. + #e.g a logfile common to installers, or a separate installer that updates a previous output. + method as_record {} { + set eventrecords [list] + foreach eobj [my events items] { + lappend eventrecords [$eobj as_record] + } + set fields [list\ + -tsiso $o_tsiso\ + -ts $o_ts\ + -name $o_name\ + -keep_events $o_keep_events\ + body $eventrecords\ + ] + set record [dict create tag INSTALLER {*}$fields] + } + #open file and save only own records + method save_all_records {} { + my save_installer_record + #todo - save FILEINFO targetset records + } + method save_installer_record {} { + set file_records [punkcheck::load_records_from_file $o_checkfile] + + set this_installer_record [my as_record] + + set persistedinfo [punkcheck::recordlist::get_installer_record $o_name $file_records] + set existing_header_posn [dict get $persistedinfo position] + if {$existing_header_posn == -1} { + set file_records [linsert $file_records 0 $this_installer_record] + } else { + lset file_records $existing_header_posn $this_installer_record + } + punkcheck::save_records_to_file $file_records $o_checkfile + } + method events {args} { + tailcall $o_events {*}$args + } + method start_event {configdict} { + if {$o_active_event ne ""} { + error "[self] start_event error - event already started: $o_active_event" + } + if {$o_rel_sourceroot eq "" || $o_rel_targetroot eq ""} { + error "[self] No configured sourceroot or targetroot. Call [self] set_source_target first" + } + + if {[llength $configdict] %2 != 0} { + error "[self] new_event configdict must have an even number of elements" + } + set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] + set existing_header_posn [dict get $resultinfo position] + if {$existing_header_posn == -1} { + error "[self] start_event - installer record missing. installer: $o_name" + } else { + set this_installer_record [dict get $resultinfo record] + } + + set eventobj [punkcheck::installevent create [namespace current]::event_[my events count] [self] $o_rel_sourceroot $o_rel_targetroot -config $configdict] + set eventid [$eventobj get_id] + set event_record [$eventobj as_record] + + set this_installer_record [punkcheck::recordlist::installer_record_add_event $this_installer_record $event_record] + set this_installer_record [punkcheck::recordlist::installer_record_pruneevents $this_installer_record $o_record_list] + + #replace + lset o_record_list $existing_header_posn $this_installer_record + + punkcheck::save_records_to_file $o_record_list $o_checkfile + set o_active_event $eventobj + my events add $eventobj $eventid + return $eventobj + } + method installer_record_from_file {} { + set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] + } + method get_recordlist {} { + return $o_recordlist + } + method end_event {} { + if {$o_active_event eq ""} { + error "[self] end_event error - no active event" + } + $o_active_event end + } + method get_event {} { + return $o_active_event + } + } + } + proc start_installer_event {punkcheck_file installername from_fullpath to_fullpath config} { + set eventid [punkcheck::uuid] + if {[file pathtype $from_fullpath] ne "absolute"} { + error "start_installer_event error: from_fullpath must be absolute path. Received '$from_fullpath'" + } + if {[file pathtype $to_fullpath] ne "absolute"} { + error "start_installer_event error: to_fullpath must be absolute path. Received '$to_fullpath'" + } + set punkcheck_folder [file dirname $punkcheck_file] + set rel_source [punkcheck::lib::path_relative $punkcheck_folder $from_fullpath] + set rel_target [punkcheck::lib::path_relative $punkcheck_folder $to_fullpath] + + + set record_list [punkcheck::load_records_from_file $punkcheck_file] + set resultinfo [punkcheck::recordlist::get_installer_record $installername $record_list] + set existing_header_posn [dict get $resultinfo position] + if {$existing_header_posn == -1} { + set this_installer_record [punkcheck::recordlist::new_installer_record $installername] + } else { + set this_installer_record [dict get $resultinfo record] + } + + set event_record [punkcheck::recordlist::new_installer_event_record install\ + -id $eventid\ + -source $rel_source\ + -targets $rel_target\ + -config $config\ + ] + + set this_installer_record [punkcheck::recordlist::installer_record_add_event $this_installer_record $event_record] + set this_installer_record [punkcheck::recordlist::installer_record_pruneevents $this_installer_record $record_list] + + if {$existing_header_posn == -1} { + #not found - prepend + set record_list [linsert $record_list 0 $this_installer_record] + } else { + #replace + lset record_list $existing_header_posn $this_installer_record + } + + punkcheck::save_records_to_file $record_list $punkcheck_file + return [list eventid $eventid recordset $record_list] + } + #----------------------------------------------- + proc installfile_help {} { + set msg "" + append msg "Call in order:" \n + append msg " start_installer_event (get dict with eventid and recordset keys)" + append msg " installfile_begin (to return a new INSTALLING record) - must pass in a valid eventid" \n + append msg " installfile_add_source_and_fetch_metadata (1+ times to update SOURCE record with checksum/timestamp info from source)" \n + append msg " ( - possibly with same algorithm as previous installrecord)" \n + append msg " ( - todo - search/load metadata for this source from other FILEINFO records for same installer)" \n + append msg "Finalize by calling:" \n + append msg " installfile_started_install" \n + append msg " (install the file e.g file copy)" \n + append msg " installfile_finished_install" \n + append msg " OR" \n + append msg " installfile_skipped_install" \n + } + proc installfile_begin {punkcheck_folder target_relpath installername args} { + if {[llength $args] %2 !=0} { + error "punkcheck installfile_begin args must be name-value pairs" + } + set target_relpath [lsort -dictionary -increasing $target_relpath] ;#exact sort order not critical - but must be consistent + set ts [clock microseconds] + set seconds [expr {$ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + set defaults [list\ + -tsiso $tsiso\ + -ts $ts\ + -installer $installername\ + -eventid unspecified\ + ] + set opts [dict merge $defaults $args] + set opt_eventid [dict get $opts -eventid] + + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set resultinfo [punkcheck::recordlist::get_installer_record $installername $record_list] + set installer_record_position [dict get $resultinfo position] + if {$installer_record_position == -1} { + error "installfile_begin error: Failed to retrieve installer record for installer name:'$installername' - ensure start_installer_event has been called with same installer, and -eventid is passed to installfile_begin" + } + set this_installer_record [dict get $resultinfo record] + set events [dict get $this_installer_record body] + set active_event [list] + foreach evt [lreverse $events] { + if {[dict get $evt -id] eq $opt_eventid} { + set active_event $evt + break + } + } + if {![llength $active_event]} { + error "installfile_begin error: eventid $opt_eventid not found for installer '$installername' - aborting" + } + + + set extractioninfo [punkcheck::recordlist::extract_or_create_fileset_record $target_relpath $record_list] + set file_record [dict get $extractioninfo record] + set record_list [dict get $extractioninfo recordset] + set isnew [dict get $extractioninfo isnew] + set oldposition [dict get $extractioninfo oldposition] + unset extractioninfo + + #INSTALL-INPROGRESS will become INSTALL-RECORD or INSTALL-FAILED or INSTALL-SKIPPED upon finalisation + #-installer and -eventid keys are added here + set new_installing_record [dict create tag INSTALL-INPROGRESS {*}$opts -tempcontext $active_event body {}] + #set existing_body [dict_getwithdefault $file_record body [list]] + #todo - look for existing "INSTALL-INPROGRESS" records - mark as failed? + dict lappend file_record body $new_installing_record + + if {$isnew} { + lappend record_list $file_record + } else { + set record_list [linsert $record_list[unset record_list] $oldposition $file_record] + } + + save_records_to_file $record_list $punkcheck_file + return $file_record + } + + #todo - ensure that removing a dependency is noticed as a change + #e.g previous installrecord had 2 source records - but we now only depend on one. + #The files we depended on for the previous record haven't changed themselves - but the list of files has (reduced by one) + proc installfile_add_source_and_fetch_metadata {punkcheck_folder source_relpath file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + error "installfile_add_source_and_fetch_metdata error: bad file_record - expected FILEINFO with last body element *-INPROGRESS ($file_record)" + } + set ts_start [clock microseconds] + set last_installrecord [lib::file_record_get_last_installrecord $file_record] + set prev_ftype "" + set prev_fsize "" + set prev_cksum "" + set prev_cksum_opts "" + if {[llength $last_installrecord]} { + set src [lib::install_record_get_matching_source_record $last_installrecord $source_relpath] + if {[llength $src]} { + if {[dict_getwithdefault $src -path ""] eq $source_relpath} { + set prev_ftype [dict_getwithdefault $src -type ""] + set prev_fsize [dict_getwithdefault $src -size ""] + set prev_cksum [dict_getwithdefault $src -cksum ""] + set prev_cksum_opts [dict_getwithdefault $src -cksum_all_opts ""] + } + } + } + #check that this relpath not already added as child of *-INPROGRESS + set file_record_body [dict_getwithdefault $file_record body [list]] ;#new file_record may have no body + set installing_record [lindex $file_record_body end] + set already_present_record [lib::install_record_get_matching_source_record $installing_record $source_relpath] + if {[llength $already_present_record]} { + error "installfile_add_source_and_fetch_metadata error: source path $source_relpath already exists in the file_record - cannot add again" + } + + if {$prev_cksum_opts ne ""} { + set cksum_opts $prev_cksum_opts + } else { + set cksum_opts "" + } + + #todo - accept argument of cached source cksum info (for client calling multiple targets with same source in quick succession e.g when building .vfs kits with multiple runtimes) + #if same cksum_opts - then use cached data instead of checksumming here. + + #allow nonexistant as a source + set fpath [file join $punkcheck_folder $source_relpath] + if {![file exists $fpath]} { + set ftype "missing" + set fsize "" + #get_relativecksum_from_base will set cksum to + set source_cksum_info [punk::mix::base::lib::get_relativecksum_from_base $punkcheck_folder $source_relpath {*}$cksum_opts] + } else { + set ftype [file type $fpath] + if {$ftype eq "directory"} { + set source_cksum_info [punk::mix::base::lib::get_relativecksum_from_base $punkcheck_folder $source_relpath {*}$cksum_opts] + set fsize "NA" + } else { + #todo - optionally use mtime instead of cksum (for files only)? + #mtime is not reliable across platforms and filesystems though.. see article linked at toop. + set source_cksum_info [punk::mix::base::lib::get_relativecksum_from_base $punkcheck_folder $source_relpath {*}$cksum_opts] + set fsize [file size $fpath] + } + } + + + lassign $source_cksum_info pathkey ckinfo + if {$pathkey ne $source_relpath} { + error "installfile_add_source_and_fetch_metadata error: cksum returned wrong path info '$pathkey' expected '$source_relpath'" + } + set cksum [dict get $ckinfo cksum] + set cksum_all_opts [dict get $ckinfo cksum_all_opts] + if {$cksum ne $prev_cksum || $ftype ne $prev_ftype || $fsize ne $prev_fsize} { + set changed 1 + } else { + set changed 0 + } + set installing_record_sources [dict_getwithdefault $installing_record body [list]] + set ts_now [clock microseconds] ;#gathering metadata - especially checsums on folder can take some time - calc and store elapsed us for time taken to gather metadata + set metadata_us [expr {$ts_now - $ts_start}] + set this_source_record [dict create tag SOURCE -type $ftype -size $fsize -path $source_relpath -cksum $cksum -cksum_all_opts $cksum_all_opts -changed $changed -metadata_us $metadata_us] + lappend installing_record_sources $this_source_record + dict set installing_record body $installing_record_sources + + lset file_record_body end $installing_record + + dict set file_record body $file_record_body + return $file_record + } + + #write back to punkcheck - don't accept recordset - invalid to update anything other than the installing_record at this time + proc installfile_started_install {punkcheck_folder file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + error "installfile_started_install error: bad file_record - expected FILEINFO with last body element *-INPROGRESS" + } + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set file_record_body [dict get $file_record body] + set targetlist [dict get $file_record -targets] + set installing_record [lindex $file_record_body end] + + set ts_start [dict get $installing_record -ts] + set ts_now [clock microseconds] + set metadata_us [expr {$ts_now - $ts_start}] + + dict set installing_record -metadata_us $metadata_us + dict set installing_record -ts_start_transfer $ts_now + + lset file_record_body end $installing_record + + dict set file_record body $file_record_body + + + set getresult [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $getresult position] + if {$old_posn == -1} { + lappend record_list $file_record + } else { + lset record_list $old_posn $file_record + } + + save_records_to_file $record_list $punkcheck_file + return $file_record + } + proc installfile_finished_install {punkcheck_folder file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + error "installfile_finished_install error: bad file_record - expected FILEINFO with last body element *-INPROGRESS" + } + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set file_record_body [dict get $file_record body] + set targetlist [dict get $file_record -targets] + set installing_record [lindex $file_record_body end] + + set ts_start [dict get $installing_record -ts] + set ts_start_transfer [dict get $installing_record -ts_start_transfer] + set ts_now [clock microseconds] + set elapsed_us [expr {$ts_now - $ts_start}] + set transfer_us [expr {$ts_now - $ts_start_transfer}] + dict set installing_record -transfer_us $transfer_us + dict set installing_record -elapsed_us $elapsed_us + dict unset installing_record -tempcontext + dict set installing_record tag "INSTALL-RECORD" + + lset file_record_body end $installing_record + dict set file_record body $file_record_body + + set file_record [punkcheck::recordlist::file_record_prune $file_record] + + set oldrecordinfo [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $oldrecordinfo position] + if {$old_posn == -1} { + lappend record_list $file_record + } else { + lset record_list $old_posn $file_record + } + + save_records_to_file $record_list $punkcheck_file + return $file_record + } + proc installfile_skipped_install {punkcheck_folder file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + set msg "installfile_skipped_install error: bad file_record - expected FILEINFO with last body element *-INPROGRESS" + append msg \n "received:" + append msg \n $file_record + error $msg + } + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set file_record_body [dict get $file_record body] + set targetlist [dict get $file_record -targets] + set installing_record [lindex $file_record_body end] + + set ts_start [dict get $installing_record -ts] + set tsnow [clock microseconds] + set elapsed_us [expr {$tsnow - $ts_start}] + dict set installing_record -elapsed_us $elapsed_us + dict set installing_record tag "INSTALL-SKIPPED" + + lset file_record_body end $installing_record + dict set file_record body $file_record_body + + set file_record [punkcheck::recordlist::file_record_prune $file_record] + + set getresult [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $getresult position] + if {$old_posn == -1} { + lappend record_list $file_record + } else { + lset record_list $old_posn $file_record + } + + save_records_to_file $record_list $punkcheck_file + return $file_record + } + #----------------------------------------------- + #then: file_record_add_installrecord + + namespace eval lib { + set pkg punkcheck + namespace path ::punkcheck + proc is_file_record_inprogress {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + return 0 + } + set installing_record [lindex [dict_getwithdefault $file_record body [list]] end] + if {[dict_getwithdefault $installing_record tag [list]] ni [list QUERY-INPROGRESS INSTALL-INPROGRESS MODIFY-INPROGRESS DELETE-INPROGRESS VIRTUAL-INPROGRESS]} { + return 0 + } + return 1 + } + proc is_file_record_installing {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + return 0 + } + set installing_record [lindex [dict_getwithdefault $file_record body [list]] end] + if {[dict_getwithdefault $installing_record tag [list]] ne "INSTALL-INPROGRESS"} { + return 0 + } + return 1 + } + proc file_record_get_last_installrecord {file_record} { + set body [dict_getwithdefault $file_record body [list]] + set previous_install_records [lrange $body 0 end-1] + #get last previous that is tagged INSTALL-RECORD,MODIFY-RECORD,VIRTUAL-RECORD + #REVIEW DELETERECORD ??? + set revlist [lreverse $previous_install_records] + foreach rec $revlist { + if {[dict get $rec tag] in [list "INSTALL-RECORD" "MODIFY-RECORD" "VIRTUAL-RECORD"]} { + return $rec + } + } + return [list] + } + + #should work on *-INPROGRESS or INSTALL(etc) record - don't restrict tag to INSTALL + proc install_record_get_matching_source_record {install_record source_relpath} { + set body [dict_getwithdefault $install_record body [list]] + foreach src $body { + if {[dict get $src tag] eq "SOURCE"} { + if {[dict_getwithdefault $src -path ""] eq $source_relpath} { + return $src + } + } + } + return [list] + } + + + + #maint warning - also in punk::mix::util + proc path_relative {base dst} { + #see also kettle + # Modified copy of ::fileutil::relative (tcllib) + # Adapted to 8.5 ({*}). + # + # Taking two _directory_ paths, a base and a destination, computes the path + # of the destination relative to the base. + # + # Arguments: + # base The path to make the destination relative to. + # dst The destination path + # + # Results: + # The path of the destination, relative to the base. + + # Ensure that the link to directory 'dst' is properly done relative to + # the directory 'base'. + + #review - check volume info on windows.. UNC paths? + if {[file pathtype $base] ne [file pathtype $dst]} { + return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)" + } + + #avoid normalizing if possible - at least for relative paths which we are likely to loop on (file normalize *very* expensive on windows) + set do_normalize 0 + if {[file pathtype $base] eq "relative"} { + #if base is relative so is dst + if {[regexp {[.]{2}} [list $base $dst]]} { + set do_normalize 1 + } + if {[regexp {[.]/} [list $base $dst]]} { + set do_normalize 1 + } + } else { + #case differences in volumes is common on windows + set do_normalize 1 + } + if {$do_normalize} { + set base [file normalize $base] + set dst [file normalize $dst] + } + + set save $dst + set base [file split $base] + set dst [file split $dst] + + while {[lindex $dst 0] eq [lindex $base 0]} { + set dst [lrange $dst 1 end] + set base [lrange $base 1 end] + if {![llength $dst]} {break} + } + + set dstlen [llength $dst] + set baselen [llength $base] + + if {($dstlen == 0) && ($baselen == 0)} { + # Cases: + # (a) base == dst + + set dst . + } else { + # Cases: + # (b) base is: base/sub = sub + # dst is: base = {} + + # (c) base is: base = {} + # dst is: base/sub = sub + + while {$baselen > 0} { + set dst [linsert $dst 0 ..] + incr baselen -1 + } + set dst [file join {*}$dst] + } + + return $dst + } + } + #skip writing punkcheck during checksum/timestamp checks + + proc install_tm_files {srcdir basedir args} { + set defaults [list\ + -glob *.tm\ + -antiglob_file [list "*[punk::mix::util::magic_tm_version]*"]\ + -installer punkcheck::install_tm_files\ + ] + set opts [dict merge $defaults $args] + punkcheck::install $srcdir $basedir {*}$opts + } + proc install_non_tm_files {srcdir basedir args} { + #set keys [dict keys $args] + #adjust the default anti_glob_dir_core entries so that .fossil-custom, .fossil-settings are copied + set antiglob_dir_core [punkcheck::default_antiglob_dir_core] + set posn [lsearch $antiglob_dir_core ".fossil*"] + if {$posn >=0} { + set antiglob_dir_core [lreplace $antiglob_dir_core $posn $posn] + } + set defaults [list\ + -glob *\ + -antiglob_file [list "*.tm" "*-buildversion.txt" "*.exe"]\ + -antiglob_dir_core $antiglob_dir_core\ + -installer punkcheck::install_non_tm_files\ + ] + set opts [dict merge $defaults $args] + punkcheck::install $srcdir $basedir {*}$opts + } + + #for tcl8.6 - tcl8.7+ has dict getwithdefault (dict getdef) + proc dict_getwithdefault {dictValue args} { + if {[llength $args] < 2} { + error {wrong # args: should be "dict_getdef dictionary ?key ...? key default"} + } + set keys [lrange $args 0 end-1] + if {[dict exists $dictValue {*}$keys]} { + return [dict get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + proc pathglob_as_re {glob} { + #any segment that is not just * must match exactly one segment in the path + set pats [list] + foreach seg [file split $glob] { + if {$seg eq "*"} { + lappend pats {[^/]*} + } elseif {$seg eq "**"} { + lappend pats {.*} + } else { + set seg [string map [list . {[.]}] $seg] + if {[regexp {[*?]} $seg]} { + set pat [string map [list * {[^/]*} ? {[^/]}] $seg] + lappend pats "$pat" + } else { + lappend pats "$seg" + } + } + } + return "^[join $pats /]\$" + } + proc globmatchpath {glob path} { + return [regexp [pathglob_as_re $glob] $path] + } + ## unidirectional file transfer to possibly non empty folder + #default of -overwrite no-targets will only copy files that are missing at the target + # -overwrite newer-targets will copy files with older source timestamp over newer target timestamp and those missing at the target (a form of 'restore' operation) + # -overwrite older-targets will copy files with newer source timestamp over older target timestamp and those missing at the target + # -overwrite all-targets will copy regardless of timestamp at target + # -overwrite installedsourcechanged-targets will copy if the target doesn't exist or the source changed + # -overwrite synced-targets will copy if the target doesn't exist or the source changed and the target cksum is the same as the last INSTALL-RECORD targets_cksums entry + # review - timestamps unreliable + # - what about slightly mismatched system clocks and mounted filesystems? caller responsibility to verify first? + # if timestamp exactly equal - should we check content-hash? This is presumably only likely to occur deliberately(maliciously?) + # e.g some process that digitally signs or otherwise modifies a file and preserves update timestmp? + # if such a content-mismatch - what default behaviour and what options would make sense? + # probably it's reasonable that only all-targets would overwrite such files. + # consider -source_fudge_seconds +-X ?, -source_override_timestamp ts ??? etc which only adjust timestamp for calculation purposes? Define a specific need/usecase when reviewing. + # + # valid filetypes for src tgt + # src dir tgt dir + # todo - review and consider enabling symlink src and dst + # no need for src file - as we use -glob with no glob characters to match one source file file + # no ability to target file with different name - keep it simpler and caller will have to use an intermediate folder/file if they need to rename something? + # + # todo - determine what happens if mismatch between file type of a src vs target e.g target has dir matching filename at source + # A pre-scan to determine no such conflict - before attempting to copy anything might provide the most integrity at slight cost in speed. + # REVIEW we should only expect dirs to be created as necessary to hold files? i.e target folder won't be created if no source file matches for that folder + # -source_checksum compare|store|comparestore|false|true where true == comparestore + # -punkcheck_folder target|source|project| target is default and is generally recommended + # -punkcheck_records empty string | parsed TDL records ie {tag xxx k v} structure + # install creates FILEINFO records with a single entry in the -targets field (it is legitimate to have a list of targets for an installation operation - the oo interface supports this) + proc install {srcdir tgtdir args} { + set defaults [list\ + -call-depth-internal 0\ + -max_depth 1000\ + -subdirlist {}\ + -createdir 0\ + -glob *\ + -antiglob_file_core "\uFFFF"\ + -antiglob_file "" \ + -antiglob_dir_core "\uFFFF"\ + -antiglob_dir {}\ + -unpublish_paths {}\ + -overwrite no-targets\ + -source_checksum comparestore\ + -punkcheck_folder target\ + -punkcheck_eventid "\uFFFF"\ + -punkcheck_records ""\ + -installer punkcheck::install\ + ] + + set opts [dict merge $defaults $args] + if {([llength $args] %2) != 0} { + error "punkcheck::install requires option-style arguments to be in pairs. Received args: $args" + } + foreach k [dict keys $args] { + if {$k ni [dict keys $defaults]} { + error "punkcheck::install unrecognised option '$k' known options: '[dict keys $defaults]'" + } + } + + #The choice to recurse using the original values of srcdir & tgtdir, and passing the subpath down as a list in -subdirlist seems an odd one. + #(as opposed to a more 'standard' mechanism of adjusting srcdir & tgtdir as we move down the tree) + #It comes from build_modules_from_source_to_base where we need to keep track of position relative to our targetdir starting point to handle submodules e.g pkg::something::mypkg-0.1.tm + #It could have been handled with some other parameter such as -depth, but this -subdirlist mechanism, whilst perhaps not beautiful, is straightforward enough + #and may be less error prone than doing slightly more opaue path manipulations at each recursion level to determine where we started + #For consistency - we'll use the same mechanism in various recursive directory walking procedures such as this one. + set CALLDEPTH [dict get $opts -call-depth-internal] ;#added for extra debug/sanity checking - clearer test for initial function call ie CALLDPEPTH = 0 + set max_depth [dict get $opts -max_depth] + set subdirlist [dict get $opts -subdirlist] ;# generally should be same length as CALLDEPTH - but user could prefill + set fileglob [dict get $opts -glob] + set createdir [dict get $opts -createdir] ;#defaults to zero to help avoid mistakes with initial target dir - required target subdirs are created regardless of this setting + + if {$CALLDEPTH == 0} { + #expensive to normalize but we need to do it at least once + set srcdir [file normalize $srcdir] + set tgtdir [file normalize $tgtdir] + if {$createdir} { + file mkdir $tgtdir + } + #now the values we build from these will be properly cased + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_antiglob_file_core [dict get $opts -antiglob_file_core] + if {$opt_antiglob_file_core eq "\uFFFF"} { + set opt_antiglob_file_core [default_antiglob_file_core] + dict set opts -antiglob_file_core $opt_antiglob_file_core + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_antiglob_file [dict get $opts -antiglob_file] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_antiglob_dir_core [dict get $opts -antiglob_dir_core] + if {$opt_antiglob_dir_core eq "\uFFFF"} { + set opt_antiglob_dir_core [default_antiglob_dir_core] + dict set opts -antiglob_dir_core $opt_antiglob_dir_core + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_antiglob_dir [dict get $opts -antiglob_dir] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_unpublish_paths [dict get $opts -unpublish_paths] ;#todo - combine with config file in source tree .punkcheckpublish (?) + set unpublish_paths_matched [list] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set known_whats [list no-targets newer-targets older-targets all-targets installedsourcechanged-targets synced-targets] + set overwrite_what [string tolower [dict get $opts -overwrite]]; #accept any case for value to allow emphasis by caller e.g -overwrite NEWER-TARGETS + if {$overwrite_what ni $known_whats} { + error "punkcheck::install received unrecognised value for -overwrite. Received value '$overwrite_what' vs known values '$known_whats'" + } + if {$overwrite_what in [list newer-targets older-targets]} { + error "punkcheck::install newer-target, older-targets not implemented - sorry" + #TODO - check crossplatform availability of ctime (on windows it still seems to be creation time, but on bsd/linux it's last attribute mod time) + # external pkg? use twapi and ctime only on other platforms? + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_source_checksum [dict get $opts -source_checksum] + if {[string is boolean $opt_source_checksum]} { + if {$opt_source_checksum} { + set opt_source_checksum "comparestore" + } else { + set opt_source_checksum 0 + } + dict set opts -source_checksum $opt_source_checksum + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_punkcheck_folder [dict get $opts -punkcheck_folder] + if {$opt_punkcheck_folder eq "target"} { + set punkcheck_folder $tgtdir + } elseif {$opt_punkcheck_folder eq "source"} { + set punkcheck_folder $srcdir + } elseif {$opt_punkcheck_folder eq "project"} { + set sourceprojectinfo [punk::repo::find_repos $srcdir] + set targetprojectinfo [punk::repo::find_repos $tgtdir] + set srcproj [lindex [dict get $sourceprojectinfo project] 0] + set tgtproj [lindex [dict get $targetprojectinfo project] 0] + if {$srcproj eq $tgtproj} { + set punkcheck_folder $tgtproj + } else { + error "copy_files_from_source_to_target error: Unable to find common project dir for source and target folder - use absolutepath for -punkcheck_folder if source and target are not within same project" + } + } else { + set punkcheck_folder $opt_punkcheck_folder + } + if {$punkcheck_folder ne ""} { + if {[file pathtype $punkcheck_folder] ne "absolute"} { + error "copy_files_from_source_to_target error: -punkcheck_folder '$punkcheck_folder' must be an absolute path, or one of: target|source|project" + } + if {![file isdirectory $punkcheck_folder]} { + error "copy_files_from_source_to_target error: -punkcheck_folder '$punkcheck_folder' not found" + } + } else { + #review - leave empty? use pwd? + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set punkcheck_records [dict get $opts -punkcheck_records] + set punkcheck_records_init $punkcheck_records ;#change-detection + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_installer [dict get $opts -installer] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_punkcheck_eventid [dict get $opts -punkcheck_eventid] + + + + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + + if {$CALLDEPTH == 0} { + set punkcheck_eventid "" + if {$punkcheck_folder ne ""} { + set config $opts + dict unset config -call-depth-internal + dict unset config -max_depth + dict unset config -subdirlist + dict for {k v} $config { + if {$v eq "\uFFFF"} { + dict unset config $k + } + } + lassign [punkcheck::start_installer_event $punkcheck_file $opt_installer $srcdir $tgtdir $config] _eventid punkcheck_eventid _recordset punkcheck_records + } + } else { + set punkcheck_eventid $opt_punkcheck_eventid + } + + + + if {$opt_source_checksum != 0} { + #we need to read the file even if only set to store (or we would overwrite entries) + set compare_cksums 1 + } else { + set compare_cksums 0 + } + + if {[string match *store* $opt_source_checksum]} { + set store_source_cksums 1 + } else { + set store_source_cksums 0 + } + + + + + + if {[llength $subdirlist] == 0} { + set current_source_dir $srcdir + set current_target_dir $tgtdir + } else { + set current_source_dir $srcdir/[file join {*}$subdirlist] + set current_target_dir $tgtdir/[file join {*}$subdirlist] + } + + + set relative_target_dir [lib::path_relative $tgtdir $current_target_dir] + if {$relative_target_dir eq "."} { + set relative_target_dir "" + } + set relative_source_dir [lib::path_relative $srcdir $current_source_dir] + if {$relative_source_dir eq "."} { + set relative_source_dir "" + } + set target_relative_to_punkcheck_dir [lib::path_relative $punkcheck_folder $current_target_dir] + if {$target_relative_to_punkcheck_dir eq "."} { + set target_relative_to_punkcheck_dir "" + } + foreach unpub $opt_unpublish_paths { + #puts "testing folder - globmatchpath $unpub $relative_source_dir" + if {[globmatchpath $unpub $relative_source_dir]} { + lappend unpublish_paths_matched $current_source_dir + return [list files_copied {} files_skipped {} sources_unchanged {} punkcheck_records $punkcheck_records unpublish_paths_matched $unpublish_paths_matched srcdir $srcdir tgtdir $tgtdir punkcheck_folder $punkcheck_folder] + } + } + + + if {![file exists $current_source_dir]} { + error "copy_files_from_source_to_target current source dir:'$current_source_dir' doesn't exist (srcdir:$srcdir tgtdir:$tgtdir args:'$args')" + } + if {![file exists $current_target_dir]} { + error "copy_files_from_source_to_target current target dir:'$current_target_dir' doesn't exist (srcdir:$srcdir tgtdir:$tgtdir args:'$args')" + } + if {([file type $current_source_dir] ni [list directory]) || ([file type $current_target_dir] ni [list directory])} { + error "copy_files_from_source_to_target requires source and target dirs to be of type 'directory' type current source: [file type $current_source_dir] type current target: [file type $current_target_dir]" + } + + set files_copied [list] + set files_skipped [list] + set sources_unchanged [list] + + + set candidate_list [glob -nocomplain -dir $current_source_dir -type f -tail $fileglob] + set hidden_candidate_list [glob -nocomplain -dir $current_source_dir -types {hidden f} -tail $fileglob] + foreach h $hidden_candidate_list { + if {$h ni $candidate_list} { + lappend candidate_list $h + } + } + set match_list [list] + foreach m $candidate_list { + set suppress 0 + foreach anti [concat $opt_antiglob_file_core $opt_antiglob_file] { + if {[string match $anti $m]} { + #puts stderr "anti: $anti vs m:$m" + set suppress 1 + break + } + } + if {$suppress == 0} { + lappend match_list $m + } + } + + #sample .punkcheck file record (raw form) to make the code clearer + #punk::tdl converts to dict form e.g: tag FILEINFO -targets filename body sublist + #Valid installrecord types are INSTALL-RECORD SKIPPED INSTALL-INPROGRESS, MODIFY-RECORD MODIFY-INPROGRESS DELETE-RECORD DELETE-INPROGRESS + # + #FILEINFO -targets jjjetc-0.1.0.tm -keep_installrecords 2 -keep_skipped 1 -keep_inprogress 2 { + # INSTALL-RECORD -tsiso 2023-09-20T07:30:30 -ts 1695159030266610 -installer punk::mix::cli::build_modules_from_source_to_base -metadata_us 18426 -ts_start_transfer 1695159030285036 -transfer_us 10194 -elapsed_us 28620 { + # SOURCE -type file -path ../src/modules/jjjetc-buildversion.txt -cksum c7c71839c36b3d21c8370fed106192fcd659eca9 -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 3423 + # SOURCE -type file -path ../src/modules/jjjetc-999999.0a1.0.tm -cksum b646fc2ee88cbd068d2e946fe929b7aea96bd39d -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 3413 + # } + # INSTALL-SKIPPED -tsiso 2023-09-20T08:14:26 -ts 1695161666087880 -installer punk::mix::cli::build_modules_from_source_to_base -elapsed_us 18914 { + # SOURCE -type file -path ../src/modules/jjjetc-buildversion.txt -cksum c7c71839c36b3d21c8370fed106192fcd659eca9 -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 0 -metadata_us 3435 + # SOURCE -type file -path ../src/modules/jjjetc-999999.0a1.0.tm -cksum b646fc2ee88cbd068d2e946fe929b7aea96bd39d -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 0 -metadata_us 3338 + # } + #} + + + #proc get_relativecksum_from_base_and_fullpath {base fullpath args} + + + #puts stdout "Current target dir: $current_target_dir" + foreach m $match_list { + set new_tgt_cksum_info [list] + set relative_target_path [file join $relative_target_dir $m] + set relative_source_path [file join $relative_source_dir $m] + set punkcheck_target_relpath [file join $target_relative_to_punkcheck_dir $m] + set is_unpublished 0 + foreach unpub $opt_unpublish_paths { + #puts "testing file - globmatchpath $unpub vs $relative_source_path" + if {[globmatchpath $unpub $relative_source_path]} { + lappend unpublish_paths_matched $current_source_dir + set is_unpublished 1 + break + } + } + if {$is_unpublished} { + continue + } + #puts stdout " checking file : $current_source_dir/$m" + set ts_start [clock microseconds] + set seconds [expr {$ts_start / 1000000}] + set ts_start_iso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + + + #puts stdout " rel_target: $punkcheck_target_relpath" + + set fetch_filerec_result [punkcheck::recordlist::get_file_record $punkcheck_target_relpath $punkcheck_records] + #change to use extract_or_create_fileset_record ? + set existing_filerec_posn [dict get $fetch_filerec_result position] + if {$existing_filerec_posn == -1} { + puts stdout "NO existing record for $punkcheck_target_relpath" + set has_filerec 0 + set new_filerec [dict create tag FILEINFO -targets $punkcheck_target_relpath] + set filerec $new_filerec + } else { + set has_filerec 1 + #puts stdout " TDL existing FILEINFO record for $punkcheck_target_relpath" + #puts stdout " $existing_install_record" + set filerec [dict get $fetch_filerec_result record] + } + set filerec [punkcheck::recordlist::file_record_set_defaults $filerec] + + #new INSTALLREC must be tagged as INSTALL-INPROGRESS to use recordlist::installfile_ method + set new_install_record [dict create tag INSTALL-INPROGRESS -tsiso $ts_start_iso -ts $ts_start -installer $opt_installer -eventid $punkcheck_eventid] + dict lappend filerec body $new_install_record ;#can't use recordlist::file_record_add_installrecord as '*-INPROGRESS' isn't a final tag - so pruning would be mucked up. No need to prune now anyway. + unset new_install_record + + + + + + set relative_source_path [lib::path_relative $punkcheck_folder $current_source_dir/$m] + #puts stdout " rel_source: $relative_source_path" + if {[file pathtype $relative_source_path] ne "relative"} { + #different volume or root + } + #Note this isn't a recordlist function - so it doesn't purely operate on the records + #this hits the filesystem for the sourcepath - gets checksums/timestamps depending on config. + #It doesn't save to .punkcheck (the only punkcheck::installfile_ method which doesn't) + set filerec [punkcheck::installfile_add_source_and_fetch_metadata $punkcheck_folder $relative_source_path $filerec] + + + + #changeinfo comes from last record in body - which is the record we are working on and so will always exist + set changeinfo [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $filerec body] end]] + set changed [dict get $changeinfo changed] + set unchanged [dict get $changeinfo unchanged] + + if {[llength $unchanged]} { + lappend sources_unchanged $current_source_dir/$m + } + + set is_skip 0 + if {$overwrite_what eq "all-targets"} { + file copy -force $current_source_dir/$m $current_target_dir + lappend files_copied $current_source_dir/$m + } else { + if {![file exists $current_target_dir/$m]} { + file copy $current_source_dir/$m $current_target_dir + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + lappend files_copied $current_source_dir/$m + incr filecount_new + } else { + if {$overwrite_what eq "installedsourcechanged-targets"} { + if {[llength $changed]} { + #An unrecorded installation is considered a source change (from unknown/unrecorded source to recorded) + file copy -force $current_source_dir/$m $current_target_dir + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + lappend files_copied $current_source_dir/$m + } else { + set is_skip 1 + lappend files_skipped $current_source_dir/$m + } + } elseif {$overwrite_what eq "synced-targets"} { + if {[llength $changed]} { + #only overwrite if the target checksum equals the last installed checksum (ie target is in sync with source and so hasn't been customized) + set existing_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + set is_target_unmodified_since_install 0 + set target_cksum_compare "unknown" + set latest_install_record [punkcheck::recordlist::file_record_latest_installrecord $filerec] ;#may be no such record - in which case we get an empty list + if {[dict exists $latest_install_record -targets_cksums]} { + set last_install_cksum [dict get $latest_install_record -targets_cksums] ;#in this case we know there is only one as 'install' always uses targetset size of 1. (FILEINFO record per file in source folder) + if {[dict get $existing_tgt_cksum_info cksum] eq $last_install_cksum} { + set is_target_unmodified_since_install 1 + set target_cksum_compare "match" + } else { + set target_cksum_compare "nomatch" + } + } else { + set target_cksum_compare "norecord" + } + if {$is_target_unmodified_since_install} { + file copy -force $current_source_dir/$m $current_target_dir + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + lappend files_copied $current_source_dir/$m + } else { + #either cksum is different or we were unable to verify the record. Either way we can't know if the target is in sync so we must skip it + set is_skip 1 + puts stderr "Skipping file copy $m target $current_target_dir/$m - require synced_target to overwrite - current target cksum compared to previous install: $target_cksum_compare" + lappend files_skipped $current_source_dir/$m + } + } else { + set is_skip 1 + lappend files_skipped $current_source_dir/$m + } + } else { + set is_skip 1 + puts stderr "Skipping file copy $m target $current_target_dir/$m already exists (use -overwrite all-targets to overwrite)" + #TODO! implement newer-targets older-targets? (note ctimes/mtimes are unreliable - may not be worth implementing) + lappend files_skipped $current_source_dir/$m + } + } + } + + + set ts_now [clock microseconds] + set elapsed_us [expr {$ts_now - $ts_start}] + + #if {$store_source_cksums} { + #} + + set install_records [dict get $filerec body] + set current_install_record [lindex $install_records end] + #change the tag from *-INPROGRESS to INSTALL-RECORD/SKIPPED + if {$is_skip} { + set tag INSTALL-SKIPPED + } else { + set tag INSTALL-RECORD + } + dict set current_install_record tag $tag + dict set current_install_record -elapsed_us $elapsed_us + if {[llength $new_tgt_cksum_info]} { + dict set current_install_record -targets_cksums [list [dict get $new_tgt_cksum_info cksum]] + dict set current_install_record -cksum_all_opts [dict get $new_tgt_cksum_info opts] + } + lset install_records end $current_install_record + dict set filerec body $install_records + set filerec [punkcheck::recordlist::file_record_prune $filerec] ;#prune now that tag is finalized + if {!$has_filerec} { + #not found in original recordlist - append + lappend punkcheck_records $filerec + } else { + lset punkcheck_records $existing_filerec_posn $filerec + } + + } + + if {$CALLDEPTH >= $max_depth} { + #don't process any more subdirs + set subdirs [list] + } else { + set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] + set hiddensubdirs [glob -nocomplain -dir $current_source_dir -type {hidden d} -tail *] + foreach h $hiddensubdirs { + if {$h in [list "." ".."]} { + continue + } + if {$h ni $subdirs} { + lappend subdirs $h + } + } + } + #puts stderr "subdirs: $subdirs" + foreach d $subdirs { + set skipd 0 + foreach dg [concat $opt_antiglob_dir_core $opt_antiglob_dir] { + if {[string match $dg $d]} { + puts stdout "SKIPPING FOLDER $d due to antiglob_dir-match: $dg " + set skipd 1 + break + } + } + if {$skipd} { + continue + } + + + if {![file exists $current_target_dir/$d]} { + file mkdir $current_target_dir/$d + } + + + set sub_opts_1 [list\ + -call-depth-internal [expr {$CALLDEPTH + 1}]\ + -subdirlist [list {*}$subdirlist $d]\ + -glob $fileglob\ + -antiglob_file_core $opt_antiglob_file_core\ + -antiglob_file $opt_antiglob_file\ + -antiglob_dir_core $opt_antiglob_dir_core\ + -antiglob_dir $opt_antiglob_dir\ + -overwrite $overwrite_what\ + -source_checksum $opt_source_checksum\ + -punkcheck_folder $punkcheck_folder\ + -punkcheck_eventid $punkcheck_eventid\ + -punkcheck_records $punkcheck_records\ + -installer $opt_installer\ + ] + set sub_opts [list\ + -call-depth-internal [expr {$CALLDEPTH + 1}]\ + -subdirlist [list {*}$subdirlist $d]\ + -punkcheck_folder $punkcheck_folder\ + -punkcheck_eventid $punkcheck_eventid\ + -punkcheck_records $punkcheck_records\ + ] + set sub_opts [dict merge $opts $sub_opts] + set sub_result [punkcheck::install $srcdir $tgtdir {*}$sub_opts] + + lappend files_copied {*}[dict get $sub_result files_copied] + lappend files_skipped {*}[dict get $sub_result files_skipped] + lappend sources_unchanged {*}[dict get $sub_result sources_unchanged] + lappend unpublish_paths_matched {*}[dict get $sub_result unpublish_paths_matched] + set punkcheck_records [dict get $sub_result punkcheck_records] + } + + if {[string match *store* $opt_source_checksum]} { + #puts "subdirlist: $subdirlist" + if {$CALLDEPTH == 0} { + if {[llength $files_copied] || [llength $files_skipped]} { + #puts stdout ">>>>>>>>>>>>>>>>>>>" + set saveresult [punkcheck::save_records_to_file $punkcheck_records $punkcheck_file] + puts stdout "punkcheck::install [dict get $saveresult recordcount] records saved as [dict get $saveresult linecount] lines to $punkcheck_file copied: [llength $files_copied] skipped: [llength $files_skipped]" + #puts stdout ">>>>>>>>>>>>>>>>>>>" + } else { + #todo - write db INSTALLER record if -debug true + + } + #puts stdout "sources_unchanged" + #puts stdout "$sources_unchanged" + #puts stdout "- -- --- --- --- ---" + } + } + + return [list files_copied $files_copied files_skipped $files_skipped sources_unchanged $sources_unchanged unpublish_paths_matched $unpublish_paths_matched punkcheck_records $punkcheck_records punkcheck_folder $punkcheck_folder srcdir $srcdir tgtdir $tgtdir] + } + proc summarize_install_resultdict {resultdict} { + set msg "" + if {[dict size $resultdict]} { + set copied [dict get $resultdict files_copied] + append msg "--------------------------" \n + append msg "[dict keys $resultdict]" \n + set tgtdir [dict get $resultdict tgtdir] + set checkfolder [dict get $resultdict punkcheck_folder] + append msg "Copied [llength $copied] files from [dict get $resultdict srcdir] to [dict get $resultdict tgtdir]" \n + foreach f $copied { + append msg "COPIED [punkcheck::lib::path_relative $checkfolder $f]" \n + append msg " TO $tgtdir" \n + } + append msg "[llength [dict get $resultdict sources_unchanged]] unchanged source files" \n + append msg "[llength [dict get $resultdict files_skipped]] skipped files" \n + append msg "--------------------------" \n + } + return $msg + } + + namespace eval recordlist { + set pkg punkcheck + namespace path ::punkcheck + + proc records_as_target_dict {record_list} { + set result [dict create] + foreach rec $record_list { + if {[dict get $rec tag] eq "FILEINFO"} { + set tgtlist [dict get $rec -targets] + dict set result $tgtlist $rec + } + } + return $result + } + + + + + #will only match if same base was used.. and same targetlist + proc get_file_record {targetlist record_list} { + set posn 0 + set found_posn -1 + set record "" + foreach rec $record_list { + if {[dict get $rec tag] eq "FILEINFO"} { + if {[dict get $rec -targets] eq $targetlist} { + set found_posn $posn + set record $rec + break + } + } + incr posn + } + return [list position $found_posn record $record] + } + proc file_install_record_source_changes {install_record} { + #reject INSTALLFAILED items ? + if {[dict get $install_record tag] ni [list "QUERY-INPROGRESS" "INSTALL-RECORD" "INSTALL-SKIPPED" "INSTALL-INPROGRESS" "MODIFY-INPROGRESS" "MODIFY-RECORD" "MODIFY-SKIPPED" "VIRTUAL-INPROGRESS" "VIRTUAL-RECORD" "VIRTUAL-SKIPPED" "DELETE-RECORD" "DELETE-INPROGRESS" "DELETE-SKIPPED"]} { + error "file_install_record_source_changes bad install record: tag '[dict get $install_record tag]' not INSTALL-RECORD|SKIPPED|INSTALL-INPROGRESS|MODIFY-RECORD|MODIFY-INPROGRESS|VIRTUAL-RECORD|VIRTUAL-INPROGRESS|DELETE-RECORD|DELETE-INPROGRESS" + } + set source_list [dict_getwithdefault $install_record body [list]] + set changed [list] + set unchanged [list] + foreach src $source_list { + if {[dict exists $src -changed]} { + if {[dict get $src -changed] !=0} { + lappend changed [dict get $src -path] + } else { + lappend unchanged [dict get $src -path] + } + } else { + lappend changed [dict get $src -path] + } + } + return [dict create changed $changed unchanged $unchanged] + } + + #assume only one for name - use first encountered + proc get_installer_record {name record_list} { + set posn 0 + set found_posn -1 + set record "" + #puts ">>>> checking [llength $record_list] punkcheck records" + foreach rec $record_list { + if {[dict get $rec tag] eq "INSTALLER"} { + if {[dict get $rec -name] eq $name} { + set found_posn $posn + set record $rec + break + } + } + incr posn + } + return [list position $found_posn record $record] + } + + proc new_installer_record {name args} { + if {[llength $args] %2 !=0} { + error "punkcheck new_installer_record args must be name-value pairs" + } + set ts [clock microseconds] + set seconds [expr {$ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + + #put -tsiso first so it lines up with -tsiso in event records + set defaults [list\ + -tsiso $tsiso\ + -ts $ts\ + -name $name\ + -keep_events 5\ + ] + set opts [dict merge $defaults $args] + + #set this_installer_record_list [punk::tdl::prettyparse [list INSTALLER name $opt_installer ts $ts tsiso $tsiso keep_events 5 {}]] + #set this_installer_record [lindex $this_installer_record_list 0] + + set record [dict create tag INSTALLER {*}$opts body {}] + + + return $record + } + proc new_installer_event_record {type args} { + if {[llength $args] %2 !=0} { + error "punkcheck new_installer_event_record args must be name-value pairs" + } + set ts [clock microseconds] + set seconds [expr {$ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + set defaults [list\ + -tsiso $tsiso\ + -ts $ts\ + -type $type\ + ] + set opts [dict merge $defaults $args] + + set record [dict create tag EVENT {*}$opts] + } + #need to scan entire set if filerecords to check if event is still referenced + proc installer_record_pruneevents {installer_record record_list} { + set keep 5 + if {[dict exists $installer_record -keep_events]} { + set keep [dict get $installer_record -keep_events] + } + + if {[dict exists $installer_record body]} { + set body_items [dict get $installer_record body] + } else { + set body_items [list] + } + set kept_body_items [list] + set kcount 0 + foreach item [lreverse $body_items] { + if {[dict get $item tag] eq "EVENT"} { + incr kcount + if {$keep < 0 || $kcount <= $keep} { + lappend kept_body_items $item + } else { + set eventid "" + if {[dict exists $item -id]} { + set eventid [dict get $item -id] + } + if {$eventid ne "" && $eventid ne "unspecified"} { + #keep if referenced, discard if not, or if eventid empty/unspecified + set is_referenced 0 + foreach rec $record_list { + if {[dict get $rec tag] eq "FILEINFO"} { + if {[dict exists $rec body]} { + foreach install [dict get $rec body] { + if {[dict exists $install -eventid] && [dict get $install -eventid] eq $eventid} { + set is_referenced 1 + break + } + } + } + } + if {$is_referenced} { + break + } + } + if {$is_referenced} { + lappend kept_body_items $item + } + } + } + } else { + lappend kept_body_items $item + } + } + set kept_body_items [lreverse $kept_body_items] + dict set installer_record body $kept_body_items + return $installer_record + } + proc installer_record_add_event {installer_record event} { + if {[dict get $installer_record tag] ne "INSTALLER"} { + error "installer_record_add_event bad installer record: tag not INSTALLER" + } + if {[dict get $event tag] ne "EVENT"} { + error "installer_record_add_event bad event record: tag not EVENT" + } + if {[dict exists $installer_record body]} { + set body_items [dict get $installer_record body] + } else { + set body_items [list] + } + lappend body_items $event + dict set installer_record body $body_items + return $installer_record + } + proc file_record_latest_installrecord {file_record} { + tailcall file_record_latest_operationrecord INSTALL $file_record + } + proc file_record_latest_operationrecord {operation file_record} { + set operation [string toupper $operation] + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_latest_operationrecord bad file_record: tag not FILEINFO" + } + if {![dict exists $file_record body]} { + return [list] + } + set body_items [dict get $file_record body] + foreach item [lreverse $body_items] { + if {[dict get $item tag] eq "$operation-RECORD"} { + return $item + } + } + return [list] + } + + + proc file_record_set_defaults {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_set_defaults bad file_record: tag not FILEINFO" + } + set defaults [list -keep_installrecords 3 -keep_skipped 1 -keep_inprogress 2] + dict for {k v} $defaults { + if {![dict exists $file_record $k]} { + dict set file_record $k $v + } + } + return $file_record + } + + #negative keep_ value will keep all + proc file_record_prune {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_prune bad file_record: tag not FILEINFO" + } + set file_record [file_record_set_defaults $file_record] + set kmap [list -keep_installrecords *-RECORD -keep_skipped *-SKIPPED -keep_inprogress *-INPROGRESS] + foreach {key rtype} $kmap { + set keep [dict get $file_record $key] + if {[dict exists $file_record body]} { + set body_items [dict get $file_record body] + } else { + set body_items [list] + } + set kept_body_items [list] + set kcount 0 + foreach item [lreverse $body_items] { + if {[string match $rtype [dict get $item tag]]} { + incr kcount + if {$keep < 0 || $kcount <= $keep} { + lappend kept_body_items $item + } + } else { + lappend kept_body_items $item + } + } + set kept_body_items [lreverse $kept_body_items] + dict set file_record body $kept_body_items + } + return $file_record + } + + #extract new or existing filerecord for path given + #review - locking/concurrency + proc extract_or_create_fileset_record {relative_target_paths recordset} { + set fetch_record_result [punkcheck::recordlist::get_file_record $relative_target_paths $recordset] + set existing_posn [dict get $fetch_record_result position] + if {$existing_posn == -1} { + #puts stdout "NO existing record for $relative_target_paths" + set isnew 1 + set fileset_record [dict create tag FILEINFO -targets $relative_target_paths body {}] + } else { + set recordset [lreplace $recordset[unset recordset] $existing_posn $existing_posn] + set isnew 0 + set fileset_record [dict get $fetch_record_result record] + } + return [list record $fileset_record recordset $recordset isnew $isnew oldposition $existing_posn] + } + + } + +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punkcheck [namespace eval punkcheck { + set pkg punkcheck + variable version + set version 0.1.0 +}] +return diff --git a/src/doc/include/general.inc b/src/doc/include/general.inc index 04950d5f..6f73d8e1 100644 --- a/src/doc/include/general.inc +++ b/src/doc/include/general.inc @@ -2,5 +2,5 @@ [comment {- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---}] [moddesc {punkshell - a Tcl }] [category {shell}] -[keywords {shell repl}] +[keywords shell repl punk] [require Tcl 8.6] diff --git a/src/make.tcl b/src/make.tcl index 64b1794c..3eec3941 100644 --- a/src/make.tcl +++ b/src/make.tcl @@ -2,8 +2,6 @@ # #make any tclkits and modules in src and place them and associated data files/scripts in the parent folder of src. #e.g in 'bin' and 'modules' folders at same level as 'src' folder. -#It is assumed the src folder has been placed somewhere where appropriate -#(e.g not in /usr or c:/ - unless you intend it to directly make and place folders and files in those locations) set hashline "# ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###" puts $hashline @@ -25,13 +23,18 @@ if {"::try" ni [info commands ::try]} { #------------------------------------------------------------------------------ #Module loading from /src/bootsupport or src/*.vfs if script is within a .vfs folder #------------------------------------------------------------------------------ -#If the there is a folder directly under the current directory /src/bootsupport/modules which contains .tm files when the starts +#If the there is a folder under the current directory /src/bootsupport/modules which contains .tm files # - then it will attempt to preference these modules -# This allows a source update via 'fossil update' 'git pull' etc to pull in support modules for the make script -# and load these in preference to ones that may have been in the interps tcl::tm::list or auto_path due to environment variables +# This allows a source update via 'fossil update' 'git pull' etc to pull in a minimal set of support modules for the make script +# and load these in preference to ones that may have been in the interp's tcl::tm::list or auto_path due to environment variables set startdir [pwd] -set bootsupport_mod [file join $startdir src bootsupport modules] -set bootsupport_lib [file join $startdir src bootsupport lib] +if {[file exists [file join $startdir src bootsupport]]} { + set bootsupport_mod [file join $startdir src bootsupport modules] + set bootsupport_lib [file join $startdir src bootsupport lib] +} else { + set bootsupport_mod [file join $startdir bootsupport modules] + set bootsupport_lib [file join $startdir bootsupport lib] +} if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} { set original_tm_list [tcl::tm::list] @@ -60,31 +63,16 @@ if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} { } - #todo - review usecase - if {[string match "*.vfs/*" [info script]]} { - #src/xxx.vfs/lib/app-punk/repl.tcl - #we assume if calling directly into .vfs that the user would prefer to use src/modules - so go up 4 levels - set modulefolder [file dirname [file dirname [file dirname [file dirname [info script]]]]]/modules - - } else { - # .../bin/punkXX.exe look for ../modules (i.e modules folder at same level as bin folder) - set modulefolder [file dirname [file dirname [info nameofexecutable]]]/modules - } - - if {[file exists $modulefolder]} { - tcl::tm::add $modulefolder - } else { - puts stderr "Warning unable to find module folder at: $modulefolder" - } if {[file exists [pwd]/modules]} { tcl::tm::add [pwd]/modules } #package require Thread - #These are strong dependencies - # - the repl requires Threading and punk,shellfilter,shellrun to call and display properly. + # - the full repl requires Threading and punk,shellfilter,shellrun to call and display properly. + + # tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list - + #These are strong dependencies package forget punk::mix package require punk::mix package forget punk::repo @@ -144,6 +132,8 @@ proc punkmake_gethelp {args} { append h " $scriptname project ?-k?" \n append h " - this is the literal word project - and confirms you want to run the project build" \n append h " - the optional -k flag will terminate processes running as the executable being built (if applicable)" \n \n + append h " $scriptname bootsupport" \n + append h " - update the src/bootsupport modules as well as the mixtemplates/layouts//src/bootsupport modules if the folder exists" \n \n append h " $scriptname get-project-info" \n append h " - show the name and base folder of the project to be built" \n append h "" \n @@ -189,7 +179,7 @@ if {[llength $commands_found] != 1 } { } if {$do_help} { puts stderr [punkmake_gethelp] - exit 1 + exit 0 } set ::punkmake::command [lindex $commands_found 0] @@ -224,6 +214,8 @@ if {![string length [set projectroot [punk::repo::find_project $scriptfolder]]]} } +set sourcefolder $projectroot/src + if {$::punkmake::command eq "get-project-info"} { puts stdout "- -- --- --- --- --- --- --- --- --- ---" puts stdout "- -- get-project-info -- -" @@ -260,9 +252,128 @@ if {$::punkmake::command eq "shell"} { } if {$::punkmake::command eq "bootsupport"} { + puts "projectroot: $projectroot" + puts "script: [info script]" + #puts "-- [tcl::tm::list] --" + puts stdout "Updating bootsupport from local files" + + proc bootsupport_localupdate {projectroot} { + set bootsupport_modules [list] + set bootsupport_config $projectroot/src/bootsupport/include_modules.config ;# + if {[file exists $bootsupport_config]} { + source $bootsupport_config ;#populate $bootsupport_modules with project-specific list + if {![llength $bootsupport_modules]} { + puts stderr "No local bootsupport modules configured for updating" + return + } + set targetroot $projectroot/src/bootsupport/modules + if {[catch { + #---------- + set boot_installer [punkcheck::installtrack new make.tcl $projectroot/src/bootsupport/.punkcheck] + $boot_installer set_source_target $projectroot $projectroot/src/bootsupport + set boot_event [$boot_installer start_event {-make_step bootsupport}] + #---------- + } errM]} { + puts stderr "Unable to use punkcheck for bootsupport error: $errM" + set boot_event "" + } - exit 1 + foreach {relpath module} $bootsupport_modules { + set module [string trim $module :] + set module_subpath [string map [list :: /] [namespace qualifiers $module]] + set srclocation [file join $projectroot $relpath $module_subpath] + #puts stdout "$relpath $module $module_subpath $srclocation" + set pkgmatches [glob -nocomplain -dir $srclocation -tail [namespace tail $module]-*] + #lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1 + if {![llength $pkgmatches]} { + puts stderr "Missing source for bootsupport module $module - not found in $srclocation" + continue + } + set latestfile [lindex $pkgmatches 0] + set latestver [lindex [split [file rootname $latestfile] -] 1] + foreach m $pkgmatches { + lassign [split [file rootname $m] -] _pkg ver + #puts "comparing $ver vs $latestver" + if {[package vcompare $ver $latestver] == 1} { + set latestver $ver + set latestfile $m + } + } + set srcfile [file join $srclocation $latestfile] + set tgtfile [file join $targetroot $module_subpath $latestfile] + if {$boot_event ne ""} { + #---------- + $boot_event targetset_init INSTALL $tgtfile + $boot_event targetset_addsource $srcfile + #---------- + if {\ + [llength [dict get [$boot_event targetset_source_changes] changed]]\ + || [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\ + } { + $boot_event targetset_started + # -- --- --- --- --- --- + puts "BOOTSUPPORT update: $srcfile -> $tgtfile" + if {[catch { + file copy -force $srcfile $tgtfile + } errM]} { + $boot_event targetset_end FAILED + } else { + $boot_event targetset_end OK + } + # -- --- --- --- --- --- + } else { + puts -nonewline stderr "." + $boot_event targetset_end SKIPPED + } + $boot_event end + } else { + file copy -force $srcfile $tgtfile + } + } + if {$boot_event ne ""} { + puts \n + $boot_event destroy + $boot_installer destroy + } + } + } + + bootsupport_localupdate $projectroot + + #/modules/punk/mix/templates/layouts only applies if the project has it's own copy of the punk/mix modules. Generally this should only apply to the punkshell project itself. + set layout_bases [list\ + $sourcefolder/mixtemplates/layouts\ + $sourcefolder/modules/punk/mix/templates/layouts\ + ] + foreach project_layout_base $layout_bases { + if {[file exists $project_layout_base]} { + set project_layouts [glob -nocomplain -dir $project_layout_base -type d -tail *] + foreach layoutname $project_layouts { + if {[file exists [file join $project_layout_base $layoutname/src/bootsupport]]} { + set unpublish [list\ + README.md\ + ] + set sourcemodules $projectroot/src/bootsupport/modules + set targetroot [file join $project_layout_base $layoutname/src/bootsupport/modules] + file mkdir $targetroot + + puts stdout "BOOTSUPPORT layouts/$layoutname: copying from $sourcemodules to $targetroot (if source file changed)" + set resultdict [punkcheck::install $sourcemodules $targetroot -overwrite installedsourcechanged-targets -unpublish_paths $unpublish] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + flush stdout + } + } + } else { + puts stderr "No layout base at $project_layout_base" + } + } + puts stdout " bootsupport done " + flush stderr + flush stdout + #punk86 can hang if calling make.tcl via 'run' without this 'after' delay. punk87 unaffected. cause unknown. + #after 500 + ::exit 0 } @@ -273,7 +384,6 @@ if {$::punkmake::command ne "project"} { } -set sourcefolder $projectroot/src #only a single consolidated /modules folder used for target set target_modules_base $projectroot/modules @@ -290,37 +400,21 @@ if {[file exists $sourcefolder/vendorlib]} { README.md\ ] + puts stdout "VENDORLIB: copying from $sourcefolder/vendorlib to $projectroot/lib (if source file changed)" set resultdict [punkcheck::install $sourcefolder/vendorlib $projectroot/lib -overwrite installedsourcechanged-targets -unpublish_paths $unpublish] - set copied [dict get $resultdict files_copied] - set sources_unchanged [dict get $resultdict sources_unchanged] - puts stdout "--------------------------" - flush stdout - puts stderr "Copied [llength $copied] vendor lib files from src/vendorlib to $projectroot/lib" - foreach f $copied { - puts stdout "COPIED $f" - } - puts stdout "[llength $sources_unchanged] unchanged source files" - puts stdout "--------------------------" + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } else { - puts stderr "NOTE: No src/vendorlib folder found." + puts stderr "VENDORLIB: No src/vendorlib folder found." } - if {[file exists $sourcefolder/vendormodules]} { #install .tm *and other files* + puts stdout "VENDORMODULES: copying from $sourcefolder/vendormodules to $target_modules_base (if source file changed)" set resultdict [punkcheck::install $sourcefolder/vendormodules $target_modules_base -installer make.tcl -overwrite installedsourcechanged-targets -unpublish_paths {README.md}] - set copied [dict get $resultdict files_copied] - set sources_unchanged [dict get $resultdict sources_unchanged] - puts stdout "--------------------------" - flush stdout - puts stderr "Copied [llength $copied] vendor module files from src/vendormodules to $target_modules_base" - foreach f $copied { - puts stdout "COPIED $f" - } - puts stdout "[llength $sources_unchanged] unchanged source files" - puts stdout "--------------------------" + puts stdout [punkcheck::summarize_install_resultdict $resultdict] } else { - puts stderr "NOTE: No src/vendormodules folder found." + puts stderr "VENDORMODULES: No src/vendormodules folder found." } ######################################################## @@ -354,6 +448,7 @@ foreach layoutinfo $layout_update_list { foreach filepair $pairs { lassign $filepair srcfile tgtfile + file mkdir [file dirname $tgtfile] #---------- $tpl_event targetset_init INSTALL $tgtfile $tpl_event targetset_addsource $srcfile @@ -386,8 +481,6 @@ foreach layoutinfo $layout_update_list { ######################################################## - - #default source module folder is at projectroot/src/modules #There may be multiple other src module folders at same level (e.g folder not being other special-purpose folder and not matching name vendor* that contains at least one .tm file in its root) set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $projectroot] @@ -403,19 +496,54 @@ foreach src_module_dir $source_module_folderlist { set overwrite "installedsourcechanged-targets" #set overwrite "ALL-TARGETS" + puts stdout "MODULEFOLDER non_tm_files $src_module_dir - copying to $target_modules_base (if source file changed)" set resultdict [punkcheck::install_non_tm_files $src_module_dir $target_modules_base -installer make.tcl -overwrite $overwrite -unpublish_paths {README.md}] - set copied [dict get $resultdict files_copied] - set sources_unchanged [dict get $resultdict sources_unchanged] - puts stdout "--------------------------" - flush stdout - puts stderr "Copied [llength $copied] non-tm source files from $src_module_dir to $target_modules_base" - puts stderr "[llength $sources_unchanged] unchanged source files" - flush stderr - puts stdout "--------------------------" + puts stdout [punkcheck::summarize_install_resultdict $resultdict] } +set installername "make.tcl" + # ---------------------------------------- +if {[punk::repo::is_fossil_root $projectroot]} { + set config [dict create\ + -make-step configure_fossil\ + ] + #---------- + set installer [punkcheck::installtrack new $installername $projectroot/.punkcheck] + $installer set_source_target $projectroot $projectroot + set event [$installer start_event $config] + $event targetset_init VIRTUAL fossil_settings_mainmenu ;#VIRTUAL - since there is no actual target file + set menufile $projectroot/.fossil-custom/mainmenu + $event targetset_addsource $menufile + #---------- + + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + } { + $event targetset_started + # -- --- --- --- --- --- + puts stdout "Configuring fossil setting: mainmenu from: $menufile" + if {[catch { + set fd [open $menufile r] + fconfigure $fd -translation binary + set data [read $fd] + close $fd + exec fossil settings mainmenu $data + } errM]} { + $event targetset_end FAILED -note "fossil update failed: $errM" + } else { + $event targetset_end OK + } + # -- --- --- --- --- --- + } else { + puts stderr "." + $event targetset_end SKIPPED + } + $event end + $event destroy + $installer destroy +} set buildfolder [punk::mix::cli::lib::get_build_workdir $sourcefolder] if {$buildfolder ne "$sourcefolder/_build"} { @@ -430,7 +558,8 @@ set rtfolder $sourcefolder/runtime set runtimes [glob -nocomplain -dir $rtfolder -types {f x} -tail *] if {![llength $runtimes]} { puts stderr "No executable runtimes found in $rtfolder - unable to build any .vfs folders into executables." - exit 2 + puts stderr "Add runtimes to $sourcefolder/runtime if required" + exit 0 } if {[catch {exec sdx help} errM]} { @@ -465,13 +594,15 @@ if {[file exists $mapfile]} { #drop windows .exe suffix so same config can work cross platform - extension will be re-added if necessary later set runtime [string range $runtime 0 end-4] } - set runtime_test $runtime - if {"windows" eq $::tcl_platform(platform)} { - set runtime_test $runtime.exe - } - if {![file exists [file join $rtfolder $runtime_test]]} { - puts stderr "WARNING: Missing runtime file $rtfolder/$runtime_test (line in mapvfs.config: $ln)" - lappend missing $runtime + if {$runtime ne "-"} { + set runtime_test $runtime + if {"windows" eq $::tcl_platform(platform)} { + set runtime_test $runtime.exe + } + if {![file exists [file join $rtfolder $runtime_test]]} { + puts stderr "WARNING: Missing runtime file $rtfolder/$runtime_test (line in mapvfs.config: $ln)" + lappend missing $runtime + } } foreach vfs $vfspaths { if {![file isdirectory [file join $sourcefolder $vfs]]} { @@ -511,7 +642,6 @@ if {![llength $vfs_folders]} { set vfs_folder_changes [dict create] ;#cache whether each .vfs folder has changes so we don't re-run tests if building from same .vfs with multiple runtime executables -set installername "make.tcl" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- #set runtimefile [lindex $runtimes 0] foreach runtimefile $runtimes { @@ -593,7 +723,7 @@ foreach vfs $vfs_folders { set runtimes_raw $runtimes set runtimes [list] foreach rt $runtimes_raw { - if {![string match *.exe $rt]} { + if {![string match *.exe $rt] && $rt ne "-"} { set rt $rt.exe } lappend runtimes $rt @@ -615,27 +745,36 @@ foreach vfs $vfs_folders { #assert $runtimes is a list of executable names suffixed with .exe if on windows - whether or not specified with .exe in the mapvfs.config + #todo - non kit based - zipkit? + # $runtimes may now include a dash entry "-" (from mapvfs.config file) foreach rtname $runtimes { + #rtname of "-" indicates build a kit without a runtime #first configured runtime will be the one to use the same name as .vfs folder for output executable. Additional runtimes on this .vfs will need to suffix the runtime name to disambiguate. #review: This mechanism may not be great for multiplatform builds ? We may be better off consistently combining vfsname and rtname and letting a later platform-specific step choose ones to install in bin with simpler names. - if {$::tcl_platform(platform) eq "windows"} { - set targetexe ${vfsname}.exe + if {$rtname eq "-"} { + set targetkit $vfsname.kit } else { - set targetexe $vfsname - } - if {$targetexe in $exe_names_seen} { - #more than one runtime for this .vfs - set targetexe ${vfsname}_$rtname + if {$::tcl_platform(platform) eq "windows"} { + set targetkit ${vfsname}.exe + } else { + set targetkit $vfsname + } + if {$targetkit in $exe_names_seen} { + #more than one runtime for this .vfs + set targetkit ${vfsname}_$rtname + } } - lappend exe_names_seen $targetexe + lappend exe_names_seen $targetkit # -- ---------- set vfs_installer [punkcheck::installtrack new $installername $basedir/.punkcheck] $vfs_installer set_source_target $sourcefolder $buildfolder set vfs_event [$vfs_installer start_event {-make-step build_vfs}] - $vfs_event targetset_init INSTALL $buildfolder/$targetexe + $vfs_event targetset_init INSTALL $buildfolder/$targetkit $vfs_event targetset_addsource $sourcefolder/$vfs - $vfs_event targetset_addsource $buildfolder/build_$rtname + if {$rtname ne "-"} { + $vfs_event targetset_addsource $buildfolder/build_$rtname + } # -- ---------- set changed_unchanged [$vfs_event targetset_source_changes] @@ -655,9 +794,17 @@ foreach vfs $vfs_folders { if {[catch { - exec sdx wrap $buildfolder/$vfsname.new -vfs $sourcefolder/$vfs -runtime $buildfolder/build_$rtname -verbose + if {$rtname ne "-"} { + exec sdx wrap $buildfolder/$vfsname.new -vfs $sourcefolder/$vfs -runtime $buildfolder/build_$rtname -verbose + } else { + exec sdx wrap $buildfolder/$vfsname.new -vfs $sourcefolder/$vfs -verbose + } } result]} { - puts stderr "sdx wrap $buildfolder/$vfsname.new -vfs $sourcefolder/$vfs -runtime $buildfolder/build_$rtname -verbose failed with msg: $result" + if {$rtname ne "-"} { + puts stderr "sdx wrap $buildfolder/$vfsname.new -vfs $sourcefolder/$vfs -runtime $buildfolder/build_$rtname -verbose failed with msg: $result" + } else { + puts stderr "sdx wrap $buildfolder/$vfsname.new -vfs $sourcefolder/$vfs -verbose failed with msg: $result" + } } else { puts stdout "ok - finished sdx" set separator [string repeat = 40] @@ -678,65 +825,74 @@ foreach vfs $vfs_folders { } else { set pscmd "ps" } - - if {![catch { - exec $pscmd | grep $vfsname - } still_running]} { - - puts stdout "found $vfsname instances still running\n" - set count_killed 0 - foreach ln [split $still_running \n] { - puts stdout " $ln" - - if {$::tcl_platform(platform) eq "windows"} { - set pid [lindex $ln 1] - if {$forcekill} { - set killcmd [list taskkill /F /PID $pid] + + #killing process doesn't apply to .kit build + if {$rtname ne "-"} { + if {![catch { + exec $pscmd | grep $vfsname + } still_running]} { + + puts stdout "found $vfsname instances still running\n" + set count_killed 0 + foreach ln [split $still_running \n] { + puts stdout " $ln" + + if {$::tcl_platform(platform) eq "windows"} { + set pid [lindex $ln 1] + if {$forcekill} { + set killcmd [list taskkill /F /PID $pid] + } else { + set killcmd [list taskkill /PID $pid] + } } else { - set killcmd [list taskkill /PID $pid] + set pid [lindex $ln 0] + #review! + if {$forcekill} { + set killcmd [list kill -9 $pid] + } else { + set killcmd [list kill $pid] + } } - } else { - set pid [lindex $ln 0] - #review! - if {$forcekill} { - set killcmd [list kill -9 $pid] + puts stdout " pid: $pid (attempting to kill now using '$killcmd')" + if {[catch { + exec {*}$killcmd + } errMsg]} { + puts stderr "$killcmd returned an error:" + puts stderr $errMsg + if {!$forcekill} { + puts stderr "(try '[info script] -k' option to force kill)" + } + #avoid exiting if the kill failure was because the task has already exited + #review - *no running instance* works with windows taskkill - "*No such process*" works with kill -9 on FreeBSD and linux - other platforms? + if {![string match "*no running instance*" $errMsg] && ![string match "*No such process*" $errMsg]} { + exit 4 + } } else { - set killcmd [list kill $pid] + puts stderr "$killcmd ran without error" + incr count_killed } } - puts stdout " pid: $pid (attempting to kill now using '$killcmd')" - if {[catch { - exec {*}$killcmd - } errMsg]} { - puts stderr "$killcmd returned an error:" - puts stderr $errMsg - puts stderr "(try '[info script] -k' option to force kill)" - exit 4 - } else { - puts stderr "$killcmd ran without error" - incr count_killed + if {$count_killed > 0} { + puts stderr "\nKilled $count_killed processes. Waiting a short time before attempting to delete executable" + after 1000 } + } else { + puts stderr "Ok.. no running '$vfsname' processes found" } - if {$count_killed > 0} { - puts stderr "\nKilled $count_killed processes. Waiting a short time before attempting to delete executable" - after 1000 - } - } else { - puts stderr "Ok.. no running '$vfsname' processes found" } - if {[file exists $buildfolder/$targetexe]} { - puts stderr "deleting existing $buildfolder/$targetexe" + if {[file exists $buildfolder/$targetkit]} { + puts stderr "deleting existing $buildfolder/$targetkit" if {[catch { - file delete $buildfolder/$targetexe + file delete $buildfolder/$targetkit } msg]} { - puts stderr "Failed to delete $buildfolder/$targetexe" + puts stderr "Failed to delete $buildfolder/$targetkit" exit 4 } } - #WINDOWS filesystem 'tunneling' (file replacement within 15secs) could cause targetexe to copy ctime & shortname metadata from previous file! + #WINDOWS filesystem 'tunneling' (file replacement within 15secs) could cause targetkit to copy ctime & shortname metadata from previous file! #This is probably harmless - but worth being aware of. - file rename $buildfolder/$vfsname.new $buildfolder/$targetexe + file rename $buildfolder/$vfsname.new $buildfolder/$targetkit # -- --- --- --- --- --- $vfs_event targetset_end OK @@ -748,36 +904,39 @@ foreach vfs $vfs_folders { # -- ---------- set bin_installer [punkcheck::installtrack new "make.tcl" $deployment_folder/.punkcheck] $bin_installer set_source_target $buildfolder $deployment_folder - set bin_event [$bin_installer start_event {-make-step final_exe_install}] - $bin_event targetset_init INSTALL $deployment_folder/$targetexe - $bin_event targetset_addsource $buildfolder/$targetexe + set bin_event [$bin_installer start_event {-make-step final_kit_install}] + $bin_event targetset_init INSTALL $deployment_folder/$targetkit + #todo - move final deployment step outside of the build vfs loop? (final deployment can fail and then isn't rerun even though _build and deployed versions differ, unless .vfs modified again) + #set last_completion [$bin_event targetset_last_complete] + + $bin_event targetset_addsource $buildfolder/$targetkit $bin_event targetset_started # -- ---------- set delete_failed 0 - if {[file exists $deployment_folder/$targetexe]} { - puts stderr "deleting existing deployed at $deployment_folder/$targetexe" + if {[file exists $deployment_folder/$targetkit]} { + puts stderr "deleting existing deployed at $deployment_folder/$targetkit" if {[catch { - file delete $deployment_folder/$targetexe + file delete $deployment_folder/$targetkit } errMsg]} { - puts stderr "deletion of deployed version at $deployment_folder/$targetexe failed: $errMsg" - #exit 5 + puts stderr "deletion of deployed version at $deployment_folder/$targetkit failed: $errMsg" set delete_failed 1 } } if {!$delete_failed} { puts stdout "copying.." - puts stdout "$buildfolder/$targetexe" + puts stdout "$buildfolder/$targetkit" puts stdout "to:" - puts stdout "$deployment_folder/$targetexe" + puts stdout "$deployment_folder/$targetkit" after 300 - file copy $buildfolder/$targetexe $deployment_folder/$targetexe + file copy $buildfolder/$targetkit $deployment_folder/$targetkit # -- ---------- $bin_event targetset_end OK # -- ---------- } else { - $bin_event targetset_end FAILED -note "could not delete + $bin_event targetset_end FAILED -note "could not delete" + exit 5 } $bin_event destroy $bin_installer destroy @@ -785,7 +944,7 @@ foreach vfs $vfs_folders { } else { set skipped_vfs_build 1 puts stderr "." - puts stdout "Skipping build for vfs $vfs - no change detected" + puts stdout "Skipping build for vfs $vfs with runtime $rtname - no change detected" $vfs_event targetset_end SKIPPED } $vfs_event destroy diff --git a/src/mixtemplates/module/template_unversioned.tm b/src/mixtemplates/module/template_unversioned.tm deleted file mode 100644 index 5b20b953..00000000 --- a/src/mixtemplates/module/template_unversioned.tm +++ /dev/null @@ -1,50 +0,0 @@ -# -*- tcl -*- -# -# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. -# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# (C) %year% -# -# @@ Meta Begin -# Application %pkg% %version% -# Meta platform tcl -# Meta license %license% -# @@ Meta End - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -##e.g package require frobz - - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval %pkg% { - - - - -} - - - - - - - - - - - - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide %pkg% [namespace eval %pkg% { - variable version - set version %version% -}] -return \ No newline at end of file diff --git a/src/modules/platform-1.0.17.tm b/src/modules/platform-1.0.17.tm deleted file mode 100644 index e01334ec..00000000 --- a/src/modules/platform-1.0.17.tm +++ /dev/null @@ -1,428 +0,0 @@ -# -*- tcl -*- -# ### ### ### ######### ######### ######### -## Overview - -# Heuristics to assemble a platform identifier from publicly available -# information. The identifier describes the platform of the currently -# running tcl shell. This is a mixture of the runtime environment and -# of build-time properties of the executable itself. -# -# Examples: -# <1> A tcl shell executing on a x86_64 processor, but having a -# wordsize of 4 was compiled for the x86 environment, i.e. 32 -# bit, and loaded packages have to match that, and not the -# actual cpu. -# -# <2> The hp/solaris 32/64 bit builds of the core cannot be -# distinguished by looking at tcl_platform. As packages have to -# match the 32/64 information we have to look in more places. In -# this case we inspect the executable itself (magic numbers, -# i.e. fileutil::magic::filetype). -# -# The basic information used comes out of the 'os' and 'machine' -# entries of the 'tcl_platform' array. A number of general and -# os/machine specific transformation are applied to get a canonical -# result. -# -# General -# Only the first element of 'os' is used - we don't care whether we -# are on "Windows NT" or "Windows XP" or whatever. -# -# Machine specific -# % amd64 -> x86_64 -# % arm* -> arm -# % sun4* -> sparc -# % ia32* -> ix86 -# % intel -> ix86 -# % i*86* -> ix86 -# % Power* -> powerpc -# % x86_64 + wordSize 4 => x86 code -# -# OS specific -# % AIX are always powerpc machines -# % HP-UX 9000/800 etc means parisc -# % linux has to take glibc version into account -# % sunos -> solaris, and keep version number -# -# NOTE: A platform like linux glibc 2.3, which can use glibc 2.2 stuff -# has to provide all possible allowed platform identifiers when -# searching search. Ditto a solaris 2.8 platform can use solaris 2.6 -# packages. Etc. This is handled by the other procedure, see below. - -# ### ### ### ######### ######### ######### -## Requirements - -namespace eval ::platform {} - -# ### ### ### ######### ######### ######### -## Implementation - -# -- platform::generic -# -# Assembles an identifier for the generic platform. It leaves out -# details like kernel version, libc version, etc. - -proc ::platform::generic {} { - global tcl_platform - - set plat [string tolower [lindex $tcl_platform(os) 0]] - set cpu $tcl_platform(machine) - - switch -glob -- $cpu { - sun4* { - set cpu sparc - } - intel - - ia32* - - i*86* { - set cpu ix86 - } - x86_64 { - if {$tcl_platform(wordSize) == 4} { - # See Example <1> at the top of this file. - set cpu ix86 - } - } - ppc - - "Power*" { - set cpu powerpc - } - "arm*" { - set cpu arm - } - ia64 { - if {$tcl_platform(wordSize) == 4} { - append cpu _32 - } - } - } - - switch -glob -- $plat { - windows { - if {$tcl_platform(platform) == "unix"} { - set plat cygwin - } else { - set plat win32 - } - if {$cpu eq "amd64"} { - # Do not check wordSize, win32-x64 is an IL32P64 platform. - set cpu x86_64 - } - } - sunos { - set plat solaris - if {[string match "ix86" $cpu]} { - if {$tcl_platform(wordSize) == 8} { - set cpu x86_64 - } - } elseif {![string match "ia64*" $cpu]} { - # sparc - if {$tcl_platform(wordSize) == 8} { - append cpu 64 - } - } - } - darwin { - set plat macosx - # Correctly identify the cpu when running as a 64bit - # process on a machine with a 32bit kernel - if {$cpu eq "ix86"} { - if {$tcl_platform(wordSize) == 8} { - set cpu x86_64 - } - } - } - aix { - set cpu powerpc - if {$tcl_platform(wordSize) == 8} { - append cpu 64 - } - } - hp-ux { - set plat hpux - if {![string match "ia64*" $cpu]} { - set cpu parisc - if {$tcl_platform(wordSize) == 8} { - append cpu 64 - } - } - } - osf1 { - set plat tru64 - } - default { - set plat [lindex [split $plat _-] 0] - } - } - - return "${plat}-${cpu}" -} - -# -- platform::identify -# -# Assembles an identifier for the exact platform, by extending the -# generic identifier. I.e. it adds in details like kernel version, -# libc version, etc., if they are relevant for the loading of -# packages on the platform. - -proc ::platform::identify {} { - global tcl_platform - - set id [generic] - regexp {^([^-]+)-([^-]+)$} $id -> plat cpu - - switch -- $plat { - solaris { - regsub {^5} $tcl_platform(osVersion) 2 text - append plat $text - return "${plat}-${cpu}" - } - macosx { - set major [lindex [split $tcl_platform(osVersion) .] 0] - if {$major > 19} { - set minor [lindex [split $tcl_platform(osVersion) .] 1] - incr major -9 - append plat $major.[expr {$minor - 1}] - } else { - incr major -4 - append plat 10.$major - return "${plat}-${cpu}" - } - return "${plat}-${cpu}" - } - linux { - # Look for the libc*.so and determine its version - # (libc5/6, libc6 further glibc 2.X) - - set v unknown - - # Determine in which directory to look. /lib, or /lib64. - # For that we use the tcl_platform(wordSize). - # - # We could use the 'cpu' info, per the equivalence below, - # that however would be restricted to intel. And this may - # be a arm, mips, etc. system. The wordsize is more - # fundamental. - # - # ix86 <=> (wordSize == 4) <=> 32 bit ==> /lib - # x86_64 <=> (wordSize == 8) <=> 64 bit ==> /lib64 - # - # Do not look into /lib64 even if present, if the cpu - # doesn't fit. - - # TODO: Determine the prefixes (i386, x86_64, ...) for - # other cpus. The path after the generic one is utterly - # specific to intel right now. Ok, on Ubuntu, possibly - # other Debian systems we may apparently be able to query - # the necessary CPU code. If we can't we simply use the - # hardwired fallback. - - switch -exact -- $tcl_platform(wordSize) { - 4 { - lappend bases /lib - if {[catch { - exec dpkg-architecture -qDEB_HOST_MULTIARCH - } res]} { - lappend bases /lib/i386-linux-gnu - } else { - # dpkg-arch returns the full tripled, not just cpu. - lappend bases /lib/$res - } - } - 8 { - lappend bases /lib64 - if {[catch { - exec dpkg-architecture -qDEB_HOST_MULTIARCH - } res]} { - lappend bases /lib/x86_64-linux-gnu - } else { - # dpkg-arch returns the full tripled, not just cpu. - lappend bases /lib/$res - } - } - default { - return -code error "Bad wordSize $tcl_platform(wordSize), expected 4 or 8" - } - } - - foreach base $bases { - if {[LibcVersion $base -> v]} break - } - - append plat -$v - return "${plat}-${cpu}" - } - } - - return $id -} - -proc ::platform::LibcVersion {base _->_ vv} { - upvar 1 $vv v - set libclist [lsort [glob -nocomplain -directory $base libc*]] - - if {![llength $libclist]} { return 0 } - - set libc [lindex $libclist 0] - - # Try executing the library first. This should suceed - # for a glibc library, and return the version - # information. - - if {![catch { - set vdata [lindex [split [exec $libc] \n] 0] - }]} { - regexp {version ([0-9]+(\.[0-9]+)*)} $vdata -> v - foreach {major minor} [split $v .] break - set v glibc${major}.${minor} - return 1 - } else { - # We had trouble executing the library. We are now - # inspecting its name to determine the version - # number. This code by Larry McVoy. - - if {[regexp -- {libc-([0-9]+)\.([0-9]+)} $libc -> major minor]} { - set v glibc${major}.${minor} - return 1 - } - } - return 0 -} - -# -- platform::patterns -# -# Given an exact platform identifier, i.e. _not_ the generic -# identifier it assembles a list of exact platform identifier -# describing platform which should be compatible with the -# input. -# -# I.e. packages for all platforms in the result list should be -# loadable on the specified platform. - -# << Should we add the generic identifier to the list as well ? In -# general it is not compatible I believe. So better not. In many -# cases the exact identifier is identical to the generic one -# anyway. -# >> - -proc ::platform::patterns {id} { - set res [list $id] - if {$id eq "tcl"} {return $res} - - switch -glob -- $id { - solaris*-* { - if {[regexp {solaris([^-]*)-(.*)} $id -> v cpu]} { - if {$v eq ""} {return $id} - foreach {major minor} [split $v .] break - incr minor -1 - for {set j $minor} {$j >= 6} {incr j -1} { - lappend res solaris${major}.${j}-${cpu} - } - } - } - linux*-* { - if {[regexp {linux-glibc([^-]*)-(.*)} $id -> v cpu]} { - foreach {major minor} [split $v .] break - incr minor -1 - for {set j $minor} {$j >= 0} {incr j -1} { - lappend res linux-glibc${major}.${j}-${cpu} - } - } - } - macosx-powerpc { - lappend res macosx-universal - } - macosx-x86_64 { - lappend res macosx-i386-x86_64 - } - macosx-ix86 { - lappend res macosx-universal macosx-i386-x86_64 - } - macosx*-* { - # 10.5+,11.0+ - if {[regexp {macosx([^-]*)-(.*)} $id -> v cpu]} { - - switch -exact -- $cpu { - ix86 { - lappend alt i386-x86_64 - lappend alt universal - } - x86_64 { - if {[lindex [split $::tcl_platform(osVersion) .] 0] < 19} { - set alt i386-x86_64 - } else { - set alt {} - } - } - arm { - lappend alt x86_64 - } - default { set alt {} } - } - - if {$v ne ""} { - foreach {major minor} [split $v .] break - - set res {} - if {$major eq 11} { - # Add 11.0 to 11.minor to patterns. - for {set j $minor} {$j >= 0} {incr j -1} { - lappend res macosx${major}.${j}-${cpu} - foreach a $alt { - lappend res macosx${major}.${j}-$a - } - } - set major 10 - set minor 15 - } - # Add 10.5 to 10.minor to patterns. - for {set j $minor} {$j >= 5} {incr j -1} { - if {$cpu ne "arm"} { - lappend res macosx${major}.${j}-${cpu} - } - foreach a $alt { - lappend res macosx${major}.${j}-$a - } - } - - # Add unversioned patterns for 10.3/10.4 builds. - lappend res macosx-${cpu} - foreach a $alt { - lappend res macosx-$a - } - } else { - # No version, just do unversioned patterns. - foreach a $alt { - lappend res macosx-$a - } - } - } else { - # no v, no cpu ... nothing - } - } - } - lappend res tcl ; # Pure tcl packages are always compatible. - return $res -} - - -# ### ### ### ######### ######### ######### -## Ready - -package provide platform 1.0.17 - -# ### ### ### ######### ######### ######### -## Demo application - -if {[info exists argv0] && ($argv0 eq [info script])} { - puts ==================================== - parray tcl_platform - puts ==================================== - puts Generic\ identification:\ [::platform::generic] - puts Exact\ identification:\ \ \ [::platform::identify] - puts ==================================== - puts Search\ patterns: - puts *\ [join [::platform::patterns [::platform::identify]] \n*\ ] - puts ==================================== - exit 0 -} diff --git a/src/modules/platform/shell-1.1.4.tm b/src/modules/platform/shell-1.1.4.tm deleted file mode 100644 index 6eb96910..00000000 --- a/src/modules/platform/shell-1.1.4.tm +++ /dev/null @@ -1,241 +0,0 @@ - -# -*- tcl -*- -# ### ### ### ######### ######### ######### -## Overview - -# Higher-level commands which invoke the functionality of this package -# for an arbitrary tcl shell (tclsh, wish, ...). This is required by a -# repository as while the tcl shell executing packages uses the same -# platform in general as a repository application there can be -# differences in detail (i.e. 32/64 bit builds). - -# ### ### ### ######### ######### ######### -## Requirements - -package require platform -namespace eval ::platform::shell {} - -# ### ### ### ######### ######### ######### -## Implementation - -# -- platform::shell::generic - -proc ::platform::shell::generic {shell} { - # Argument is the path to a tcl shell. - - CHECK $shell - LOCATE base out - - set code {} - # Forget any pre-existing platform package, it might be in - # conflict with this one. - lappend code {package forget platform} - # Inject our platform package - lappend code [list source $base] - # Query and print the architecture - lappend code {puts [platform::generic]} - # And done - lappend code {exit 0} - - set arch [RUN $shell [join $code \n]] - - if {$out} {file delete -force $base} - return $arch -} - -# -- platform::shell::identify - -proc ::platform::shell::identify {shell} { - # Argument is the path to a tcl shell. - - CHECK $shell - LOCATE base out - - set code {} - # Forget any pre-existing platform package, it might be in - # conflict with this one. - lappend code {package forget platform} - # Inject our platform package - lappend code [list source $base] - # Query and print the architecture - lappend code {puts [platform::identify]} - # And done - lappend code {exit 0} - - set arch [RUN $shell [join $code \n]] - - if {$out} {file delete -force $base} - return $arch -} - -# -- platform::shell::platform - -proc ::platform::shell::platform {shell} { - # Argument is the path to a tcl shell. - - CHECK $shell - - set code {} - lappend code {puts $tcl_platform(platform)} - lappend code {exit 0} - - return [RUN $shell [join $code \n]] -} - -# ### ### ### ######### ######### ######### -## Internal helper commands. - -proc ::platform::shell::CHECK {shell} { - if {![file exists $shell]} { - return -code error "Shell \"$shell\" does not exist" - } - if {![file executable $shell]} { - return -code error "Shell \"$shell\" is not executable (permissions)" - } - return -} - -proc ::platform::shell::LOCATE {bv ov} { - upvar 1 $bv base $ov out - - # Locate the platform package for injection into the specified - # shell. We are using package management to find it, whereever it - # is, instead of using hardwired relative paths. This allows us to - # install the two packages as TMs without breaking the code - # here. If the found package is wrapped we copy the code somewhere - # where the spawned shell will be able to read it. - - # This code is brittle, it needs has to adapt to whatever changes - # are made to the TM code, i.e. the provide statement generated by - # tm.tcl - - set pl [package ifneeded platform [package require platform]] - set base [lindex $pl end] - - set out 0 - if {[lindex [file system $base]] ne "native"} { - set temp [TEMP] - file copy -force $base $temp - set base $temp - set out 1 - } - return -} - -proc ::platform::shell::RUN {shell code} { - set c [TEMP] - set cc [open $c w] - puts $cc $code - close $cc - - set e [TEMP] - - set code [catch { - exec $shell $c 2> $e - } res] - - file delete $c - - if {$code} { - append res \n[read [set chan [open $e r]]][close $chan] - file delete $e - return -code error "Shell \"$shell\" is not executable ($res)" - } - - file delete $e - return $res -} - -proc ::platform::shell::TEMP {} { - set prefix platform - - # This code is copied out of Tcllib's fileutil package. - # (TempFile/tempfile) - - set tmpdir [DIR] - - set chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" - set nrand_chars 10 - set maxtries 10 - set access [list RDWR CREAT EXCL TRUNC] - set permission 0600 - set channel "" - set checked_dir_writable 0 - set mypid [pid] - for {set i 0} {$i < $maxtries} {incr i} { - set newname $prefix - for {set j 0} {$j < $nrand_chars} {incr j} { - append newname [string index $chars \ - [expr {int(rand()*62)}]] - } - set newname [file join $tmpdir $newname] - if {[file exists $newname]} { - after 1 - } else { - if {[catch {open $newname $access $permission} channel]} { - if {!$checked_dir_writable} { - set dirname [file dirname $newname] - if {![file writable $dirname]} { - return -code error "Directory $dirname is not writable" - } - set checked_dir_writable 1 - } - } else { - # Success - close $channel - return [file normalize $newname] - } - } - } - if {$channel ne ""} { - return -code error "Failed to open a temporary file: $channel" - } else { - return -code error "Failed to find an unused temporary file name" - } -} - -proc ::platform::shell::DIR {} { - # This code is copied out of Tcllib's fileutil package. - # (TempDir/tempdir) - - global tcl_platform env - - set attempdirs [list] - - foreach tmp {TMPDIR TEMP TMP} { - if { [info exists env($tmp)] } { - lappend attempdirs $env($tmp) - } - } - - switch $tcl_platform(platform) { - windows { - lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP" - } - macintosh { - set tmpdir $env(TRASH_FOLDER) ;# a better place? - } - default { - lappend attempdirs \ - [file join / tmp] \ - [file join / var tmp] \ - [file join / usr tmp] - } - } - - lappend attempdirs [pwd] - - foreach tmp $attempdirs { - if { [file isdirectory $tmp] && [file writable $tmp] } { - return [file normalize $tmp] - } - } - - # Fail if nothing worked. - return -code error "Unable to determine a proper directory for temporary files" -} - -# ### ### ### ######### ######### ######### -## Ready - -package provide platform::shell 1.1.4 diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index f1d0214b..37529a9d 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -3,8 +3,13 @@ namespace eval punk { - package require zzzload - zzzload::pkg_require twapi + proc lazyload {pkg} { + package require zzzload + if {[package provide $pkg] eq ""} { + zzzload::pkg_require $pkg + } + } + #lazyload twapi catch {package require vfs} ;#attempt load now so we can use faster 'package provide' to test existence later } @@ -165,15 +170,47 @@ namespace eval punk { proc ::punk::K {x y} { return $x} + proc stacktrace {} { + set stack "Stack trace:\n" + for {set i 1} {$i < [info level]} {incr i} { + set lvl [info level -$i] + set pname [lindex $lvl 0] + append stack [string repeat " " $i]$pname + + if {![catch {info args $pname} pargs]} { + foreach value [lrange $lvl 1 end] arg $pargs { + + if {$value eq ""} { + if {$arg != 0} { + info default $pname $arg value + } + } + append stack " $arg='$value'" + } + } else { + append stack " !unknown vars for $pname" + } + + append stack \n + } + return $stack + } proc ::punk::uuid {} { set has_twapi 0 - if {"windows" eq $::tcl_platform(platform)} { - set loader [zzzload::pkg_wait twapi] - if {$loader in [list failed loading]} { - puts stderr "Unexpected problem during thread-load of pkg twapi - zzload::pkg_wait returned $loader" - } - if {[package provide twapi] ne ""} { - set has_twapi 1 + if 0 { + if {"windows" eq $::tcl_platform(platform)} { + if {![catch { + set loader [zzzload::pkg_wait twapi] + } errM]} { + if {$loader in [list failed loading]} { + puts stderr "Unexpected problem during thread-load of pkg twapi - zzload::pkg_wait returned $loader" + } + } else { + package require twapi + } + if {[package provide twapi] ne ""} { + set has_twapi 1 + } } } if {!$has_twapi} { diff --git a/src/modules/punk/ansi-999999.0a1.0.tm b/src/modules/punk/ansi-999999.0a1.0.tm index 176d0896..9d6ddf97 100644 --- a/src/modules/punk/ansi-999999.0a1.0.tm +++ b/src/modules/punk/ansi-999999.0a1.0.tm @@ -158,7 +158,7 @@ namespace eval punk::ansi { overline 53 nooverline 55 frame 51 framecircle 52 noframe 54 } variable SGR_colour_map { - black 30 red 31 green 32 yellow 33 blue 4 purple 35 cyan 36 white 37 + black 30 red 31 green 32 yellow 33 blue 34 purple 35 cyan 36 white 37 Black 40 Red 41 Green 42 Yellow 43 Blue 44 Purple 45 Cyan 46 White 47 BLACK 100 RED 101 GREEN 102 YELLOW 103 BLUE 104 PURPLE 105 CYAN 106 WHITE 107 } diff --git a/src/modules/punk/console-999999.0a1.0.tm b/src/modules/punk/console-999999.0a1.0.tm index 1cf8bb2c..8a6377cc 100644 --- a/src/modules/punk/console-999999.0a1.0.tm +++ b/src/modules/punk/console-999999.0a1.0.tm @@ -21,8 +21,8 @@ package require punk::ansi if {"windows" eq $::tcl_platform(platform)} { - package require zzzload - zzzload::pkg_require twapi + #package require zzzload + #zzzload::pkg_require twapi } #see https://learn.microsoft.com/en-us/windows/console/classic-vs-vt @@ -129,8 +129,12 @@ namespace eval punk::console { } } proc define_windows_procs {} { + package require zzzload set loadstate [zzzload::pkg_require twapi] - if {$loadstate ni [list loading failed]} { + if {$loadstate ni [list failed]} { + #review zzzload usage + #puts stdout "=========== console loading twapi =============" + zzzload::pkg_wait twapi package require twapi ;#should be fast once twapi dll loaded in zzzload thread set ::punk::console::has_twapi 1 diff --git a/src/modules/punk/mix/base-0.1.tm b/src/modules/punk/mix/base-0.1.tm index 190c2ea1..0f131936 100644 --- a/src/modules/punk/mix/base-0.1.tm +++ b/src/modules/punk/mix/base-0.1.tm @@ -284,7 +284,7 @@ namespace eval punk::mix::base { # puts stdout "base doingstuff-with-args:'$args'-in-namespace:'[namespace current]'" #} namespace eval lib { - + variable sha3_implementation "" ;#set by cksum_algorithms (which is called by cksum_path) It looks for fossil or sqlite3. Todo - add proper Tcl implementation. namespace export * #----------------------------------------------------- @@ -445,9 +445,28 @@ namespace eval punk::mix::base { #adler32 is fastest for some larger files of a few MB but slower on small files (possibly due to Tcl-based file load?) #sha1 as at 2023 seems a good default proc cksum_algorithms {} { + variable sha3_implementation #sha2 is an alias for sha256 - #2023 - no sha3 available in tcllib - return [list md5 sha1 sha2 sha256 cksum adler32] + #2023 - no sha3 available in tcllib - we can exec fossil for now - which will be very slow + set algs [list md5 sha1 sha2 sha256 cksum adler32] + set sha3_algs [list sha3 sha3-224 sha3-256 sha3-384 sha3-512] + if {[auto_execok sqlite3] ne ""} { + lappend algs {*}$sha3_algs + set sha3_implementation sqlite3_sha3 + } else { + if {[auto_execok fossil] ne ""} { + lappend algs {*}$sha3_algs + set sha3_implementation fossil_sha3 + } + } + return $algs + } + + proc sqlite3_sha3 {bits filename} { + return [exec sqlite3 :memory: "select lower(hex(sha3(readfile('$filename'),$bits)))"] + } + proc fossil_sha3 {bits filename} { + return [lindex [exec fossil sha3sum -$bits $filename] 0] } #adler32 via file-slurp @@ -465,6 +484,7 @@ namespace eval punk::mix::base { #-noperms only available on extraction - so that doesn't help #Needs to operate on non-existant paths and return empty string in cksum field proc cksum_path {path args} { + variable sha3_implementation if {$path eq {}} { set path [pwd] } if {[file pathtype $path] eq "relative"} { set path [file normalize $path] @@ -473,6 +493,13 @@ namespace eval punk::mix::base { set startdir [pwd] set defaults [cksum_default_opts] + set known_opts [dict keys $defaults] + foreach {k v} $args { + if {$k ni $known_opts} { + error "cksum_path unknown option '$k' known_options: $known_opts" + } + } + set opts [dict merge $defaults $args] set opts_actual $opts ;#default - auto updated to 0 or 1 later @@ -582,6 +609,14 @@ namespace eval punk::mix::base { set cksum_command [list crc::cksum -format 0x%X -file] } elseif {$opt_cksum_algorithm eq "adler32"} { set cksum_command [list cksum_adler32_file] + } elseif {$opt_cksum_algorithm in [list "sha3" "sha3-256"]} { + #todo - replace with something that doesn't call another process + #set cksum_command [list apply {{file} {lindex [exec fossil sha3sum -256 $file] 0}}] + set cksum_command [list $sha3_implementation 256] + } elseif {$opt_cksum_algorithm in [list "sha3-224" "sha3-384" "sha3-512"]} { + set bits [lindex [split $opt_cksum_algorithm -] 1] + #set cksum_command [list apply {{bits file} {lindex [exec fossil sha3sum -$bits $file] 0}} $bits] + set cksum_command [list $sha3_implementation $bits] } set cksum "" diff --git a/src/modules/punk/mix/cli-0.3.tm b/src/modules/punk/mix/cli-0.3.tm index 9e75c3ee..69672265 100644 --- a/src/modules/punk/mix/cli-0.3.tm +++ b/src/modules/punk/mix/cli-0.3.tm @@ -32,34 +32,42 @@ namespace eval punk::mix::cli { package require punk::overlay catch { - punk::overlay::import_commandset module. ::punk::mix::commandset::module + punk::overlay::import_commandset module . ::punk::mix::commandset::module } - punk::overlay::import_commandset debug. ::punk::mix::commandset::debug - punk::overlay::import_commandset repo. ::punk::mix::commandset::repo - punk::overlay::import_commandset lib. ::punk::mix::commandset::loadedlib + punk::overlay::import_commandset debug . ::punk::mix::commandset::debug + punk::overlay::import_commandset repo . ::punk::mix::commandset::repo + punk::overlay::import_commandset lib . ::punk::mix::commandset::loadedlib catch { package require punk::mix::commandset::project - punk::overlay::import_commandset project. ::punk::mix::commandset::project - punk::overlay::import_commandset "" ::punk::mix::commandset::project::collection + punk::overlay::import_commandset project . ::punk::mix::commandset::project + punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection } if {[catch { package require punk::mix::commandset::layout - punk::overlay::import_commandset project.layout. ::punk::mix::commandset::layout - punk::overlay::import_commandset "project." ::punk::mix::commandset::layout::collection + punk::overlay::import_commandset project.layout . ::punk::mix::commandset::layout + punk::overlay::import_commandset project.layouts . ::punk::mix::commandset::layout::collection } errM]} { puts stderr "error loading punk::mix::commandset::layout" puts stderr $errM } if {[catch { package require punk::mix::commandset::buildsuite - punk::overlay::import_commandset buildsuite. ::punk::mix::commandset::buildsuite - punk::overlay::import_commandset "" ::punk::mix::commandset::buildsuite::collection + punk::overlay::import_commandset buildsuite . ::punk::mix::commandset::buildsuite + punk::overlay::import_commandset buildsuites . ::punk::mix::commandset::buildsuite::collection } errM]} { puts stderr "error loading punk::mix::commandset::buildsuite" puts stderr $errM } - punk::overlay::import_commandset scriptwrap. ::punk::mix::commandset::scriptwrap + punk::overlay::import_commandset scriptwrap . ::punk::mix::commandset::scriptwrap + if {[catch { + package require punk::mix::commandset::doc + punk::overlay::import_commandset doc . ::punk::mix::commandset::doc + punk::overlay::import_commandset "" "" ::punk::mix::commandset::doc::collection + } errM]} { + puts stderr "error loading punk::mix::commandset::doc" + puts stderr $errM + } proc help {args} { @@ -148,21 +156,28 @@ namespace eval punk::mix::cli { set lc_proj_bin [string tolower $project_base/bin] set lc_build_bin [string tolower $project_base/src/_build] - - set is_own_exe 0 - if {[string match "${lc_proj_bin}*" $lc_this_exe] || [string match "${lc_build_bin}" $lc_this_exe]} { - set is_own_exe 1 - puts stderr "WARNING - running make using executable that may be created by the project being built" - set answer [util::askuser "Do you want to proceed using this executable? (build will probably stop when it is unable to update the executable) Y|N"] - if {[string tolower $answer] ne "y"} { - puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." - return + if {"project" in $args} { + set is_own_exe 0 + if {[string match "${lc_proj_bin}*" $lc_this_exe] || [string match "${lc_build_bin}" $lc_this_exe]} { + set is_own_exe 1 + puts stderr "WARNING - running make using executable that may be created by the project being built" + set answer [util::askuser "Do you want to proceed using this executable? (build will probably stop when it is unable to update the executable) Y|N"] + if {[string tolower $answer] ne "y"} { + puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." + return + } } } cd $sourcefolder #use run so that stdout visible as it goes - set exitinfo [run [info nameofexecutable] $sourcefolder/make.tcl project] - set exitcode [dict get $exitinfo exitcode] + if {![catch {run --timeout=5000 -debug [info nameofexecutable] $sourcefolder/make.tcl {*}$args} exitinfo]} { + puts stderr "exitinfo: $exitinfo" + set exitcode [dict get $exitinfo exitcode] + } else { + puts stderr "Error unable to determine exitcode. err: $exitinfo" + cd $startdir + return false + } cd $startdir if {$exitcode != 0} { @@ -388,7 +403,7 @@ namespace eval punk::mix::cli { -call-depth-internal 0\ -max_depth 1000\ -subdirlist {}\ - -punkcheck_eventid "\uFFFF"\ + -punkcheck_eventobj "\uFFFF"\ -glob *.tm\ ] set opts [dict merge $defaults $args] @@ -405,7 +420,7 @@ namespace eval punk::mix::cli { error "build_modules_from_source_to_base -glob '$fileglob' doesn't seem to target tcl modules." } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - set opt_punkcheck_eventid [dict get $opts -punkcheck_eventid] + set opt_punkcheck_eventobj [dict get $opts -punkcheck_eventobj] set magicversion [punk::mix::util::magic_tm_version] ;#deliberately large so given load-preference when testing set module_list [list] @@ -443,10 +458,15 @@ namespace eval punk::mix::cli { -glob $fileglob\ -max_depth 0\ ] - lassign [punkcheck::start_installer_event $punkcheck_file $installername $srcdir $basedir $config] _eventid punkcheck_eventid _recordset record_list + #lassign [punkcheck::start_installer_event $punkcheck_file $installername $srcdir $basedir $config] _eventid punkcheck_eventid _recordset record_list + # -- --- + set installer [punkcheck::installtrack new $installername $punkcheck_file] + $installer set_source_target $srcdir $basedir + set event [$installer start_event $config] + # -- --- } else { - set punkcheck_eventid $opt_punkcheck_eventid + set event $opt_punkcheck_eventobj } #---------------------------------------- @@ -482,6 +502,7 @@ namespace eval punk::mix::cli { if {[file exists $current_source_dir/#tarjar-$basename-$magicversion]} { + #TODO file mkdir $buildfolder if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} { @@ -519,24 +540,31 @@ namespace eval punk::mix::cli { #------------------------------ # - set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$basename-$module_build_version.tm] - - set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] - - set changed_list [list] - # -- --- --- --- --- --- - set source_relpath [punkcheck::lib::path_relative $basedir $versionfile] - set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] - # -- --- --- --- --- --- - set source_relpath [punkcheck::lib::path_relative $basedir $current_source_dir/$m] - set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] - # -- --- --- --- --- --- - set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] - set changed_list [dict get $changed_unchanged changed] - - - if {[llength $changed_list]} { - set file_record [punkcheck::installfile_started_install $basedir $file_record] + #set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$basename-$module_build_version.tm] + #set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] + $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm + $event targetset_addsource $versionfile + $event targetset_addsource $current_source_dir/$m + + #set changed_list [list] + ## -- --- --- --- --- --- + #set source_relpath [punkcheck::lib::path_relative $basedir $versionfile] + #set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] + ## -- --- --- --- --- --- + #set source_relpath [punkcheck::lib::path_relative $basedir $current_source_dir/$m] + #set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] + ## -- --- --- --- --- --- + #set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] + #set changed_list [dict get $changed_unchanged changed] + + + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ + } { + + #set file_record [punkcheck::installfile_started_install $basedir $file_record] + $event targetset_started # -- --- --- --- --- --- set target $target_module_dir/$basename-$module_build_version.tm if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} @@ -550,12 +578,14 @@ namespace eval punk::mix::cli { #file copy -force $srcdir/$m $target lappend module_list $target # -- --- --- --- --- --- - set file_record [punkcheck::installfile_finished_install $basedir $file_record] + #set file_record [punkcheck::installfile_finished_install $basedir $file_record] + $event targetset_end OK } else { #puts stdout "skipping module $current_source_dir/$m - no change in sources detected" puts -nonewline stderr "." set did_skip 1 - set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $event targetset_end SKIPPED } #------------------------------ @@ -572,33 +602,41 @@ namespace eval punk::mix::cli { exit 1 } - #------------------------------ - # - set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$m] - - set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] - - set changed_list [list] - # -- --- --- --- --- --- - set source_relpath [punkcheck::lib::path_relative $basedir $current_source_dir/$m] - set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] - # -- --- --- --- --- --- - set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] - set changed_list [dict get $changed_unchanged changed] - - if {[llength $changed_list]} { - set file_record [punkcheck::installfile_started_install $basedir $file_record] + ##------------------------------ + ## + #set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$m] + #set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] + #set changed_list [list] + ## -- --- --- --- --- --- + #set source_relpath [punkcheck::lib::path_relative $basedir $current_source_dir/$m] + #set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] + ## -- --- --- --- --- --- + #set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] + #set changed_list [dict get $changed_unchanged changed] + + #---------- + $event targetset_init INSTALL $target_module_dir/$m + $event targetset_addsource $current_source_dir/$m + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ + } { + + #set file_record [punkcheck::installfile_started_install $basedir $file_record] + $event targetset_started # -- --- --- --- --- --- if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} puts stderr "Copied already versioned module $current_source_dir/$m to $target_module_dir" lappend module_list $current_source_dir/$m file copy -force $current_source_dir/$m $target_module_dir # -- --- --- --- --- --- - set file_record [punkcheck::installfile_finished_install $basedir $file_record] + #set file_record [punkcheck::installfile_finished_install $basedir $file_record] + $event targetset_end OK -note "already versioned module" } else { puts -nonewline stderr "." set did_skip 1 - set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $event targetset_end SKIPPED } } @@ -625,17 +663,90 @@ namespace eval punk::mix::cli { lappend module_list {*}[build_modules_from_source_to_base $srcdir $basedir\ -call-depth-internal [expr {$CALLDEPTH +1}]\ -subdirlist [list {*}$subdirlist $d]\ - -punkcheck_eventid $punkcheck_eventid\ + -punkcheck_eventobj $event\ -glob $fileglob\ ] } if {$did_skip} { puts -nonewline stdout \n } + if {$CALLDEPTH == 0} { + $event destroy + $installer destroy + } return $module_list } + variable kettle_reset_bodies [dict create] + variable kettle_reset_args [dict create] + #We are abusing kettle to run in-process. + # when we change to another project we need recipes to be reloaded. + # Kettle rewrites some of it's own procs - stopping reloading of recipes when we change folders + #kettle_init stores the original proc bodies & args + proc kettle_init {} { + variable kettle_reset_bodies ;#dict + variable kettle_reset_args + set reset_procs [list\ + ::kettle::benchmarks\ + ::kettle::doc\ + ::kettle::figures\ + ::kettle::meta::scan\ + ::kettle::testsuite\ + ] + foreach p $reset_procs { + set b [info body $p] + if {[string match "*Overwrite self*" $b]} { + dict set kettle_reset_bodies $p $b + set argnames [info args $p] + set arglist [list] + foreach a $argnames { + if {[info default $p $a dval]} { + lappend arglist [list $a $dval] + } else { + lappend arglist $a + } + } + dict set kettle_reset_args $p $arglist + } + } + + } + #call kettle_reinit to ensure recipes point to current project + proc kettle_reinit {} { + variable kettle_reset_bodies + variable kettle_reset_args + foreach p [dict keys $kettle_reset_bodies] { + set b [dict get $kettle_reset_bodies $p] + set argl [dict get $kettle_reset_args $p] + uplevel 1 [list ::proc $p $argl $b] + } + #todo - determine standard recipes by examining standard.tcl instead of hard coding? + set standard_recipes [list\ + null\ + forever\ + list-recipes\ + help-recipes\ + help-dump\ + help-recipes\ + help\ + list\ + list-options\ + help-options\ + show-configuration\ + show-state\ + show\ + meta-status\ + gui\ + ] + #set ::kettle::recipe::recipe [dict create] + foreach r [dict keys $::kettle::recipe::recipe] { + if {$r ni $standard_recipes} { + dict unset ::kettle::recipe::recipe $r + } + } + } proc kettle_call {calltype args} { + variable kettle_reset_bodies if {$calltype ni [list lib shell]} { error "pmix kettle_call 1st argument must be one of: 'lib' for direct use of kettle module or 'shell' to call as separate process" } @@ -659,9 +770,18 @@ namespace eval punk::mix::cli { if {![file exists $startdir/build.tcl]} { error "pmix kettle must be run from a folder containing build.tcl (cwd: [pwd])" } - if {[catch {package present kettle}]} { + if {[package provide kettle] eq ""} { puts stdout "Loading kettle package - may be delay on first load ..." package require kettle + kettle_init ;#store original procs for those kettle procs that rewrite themselves + } else { + if {[dict size $kettle_reset_bodies] == 0} { + #presumably package require kettle was called without calling our kettle_init hack. + kettle_init + } else { + #undo proc rewrites + kettle_reinit + } } set first [lindex $args 0] if {[string match @* $first]} { diff --git a/src/modules/punk/mix/commandset/buildsuite-999999.0a1.0.tm b/src/modules/punk/mix/commandset/buildsuite-999999.0a1.0.tm index 014239cd..fbe03676 100644 --- a/src/modules/punk/mix/commandset/buildsuite-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/buildsuite-999999.0a1.0.tm @@ -107,7 +107,7 @@ namespace eval punk::mix::commandset::buildsuite { namespace eval collection { namespace export * - proc buildsuites {{glob {}}} { + proc _default {{glob {}}} { if {![string length $glob]} { set glob * } diff --git a/src/modules/punk/mix/commandset/doc-999999.0a1.0.tm b/src/modules/punk/mix/commandset/doc-999999.0a1.0.tm new file mode 100644 index 00000000..b7be1384 --- /dev/null +++ b/src/modules/punk/mix/commandset/doc-999999.0a1.0.tm @@ -0,0 +1,181 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application punk::mix::commandset::doc 999999.0a1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::mix::commandset::doc { + namespace export * + + proc _default {} { + puts "documentation subsystem" + puts "commands: doc.build" + puts " build documentation from src/doc to src/embedded using the kettle build tool" + } + + proc build {} { + puts "build docs" + set projectdir [punk::repo::find_project] + if {$projectdir eq ""} { + puts stderr "No current project dir - unable to build docs" + return + } + if {[file exists $projectdir/src/doc]} { + set original_wd [pwd] + cd $projectdir/src + #---------- + set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] + $installer set_source_target $projectdir/src/doc $projectdir/src/embedded + set event [$installer start_event {-install_step kettledoc}] + #use same virtual id "kettle_build_doc" as project.new - review best way to keep identifiers like this in sync. + $event targetset_init VIRTUAL kettle_build_doc ;#VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated + $event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source + #---------- + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + } { + $event targetset_started + # -- --- --- --- --- --- + puts stdout "BUILDING DOCS at $projectdir/src/embedded from src/doc" + if {[catch { + + punk::mix::cli::lib::kettle_call lib doc + #Kettle doc + + } errM]} { + $event targetset_end FAILED -note "kettle_build_doc failed: $errM" + } else { + $event targetset_end OK + } + # -- --- --- --- --- --- + } else { + puts stderr "No change detected in src/doc" + $event targetset_end SKIPPED + } + $event end + $event destroy + $installer destroy + cd $original_wd + } else { + puts stderr "No doc folder found at $projectdir/src/doc" + } + } + proc status {} { + set projectdir [punk::repo::find_project] + if {$projectdir eq ""} { + puts stderr "No current project dir - unable to check doc status" + return + } + if {![file exists $projectdir/src/doc]} { + set result "No documentation source found. Expected .man files in doctools format at $projectdir/src/doc" + return $result + } + set original_wd [pwd] + cd $projectdir/src + puts stdout "Testing status of doctools source location $projectdir/src/doc ..." + flush stdout + #---------- + set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] + $installer set_source_target $projectdir/src/doc $projectdir/src/embedded + set event [$installer start_event {-install_step kettledoc}] + #use same virtual id "kettle_build_doc" as project.new - review best way to keep identifiers like this in sync. + $event targetset_init QUERY kettle_build_doc ;#usually VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated - but here we use QUERY to ensure no writes to .punkcheck + set last_completion [$event targetset_last_complete] + + if {[llength $last_completion]} { + #adding a source causes it to be checksummed + $event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source + #---------- + set changeinfo [$event targetset_source_changes] + if {\ + [llength [dict get $changeinfo changed]]\ + } { + puts stdout "changed" + puts stdout $changeinfo + } else { + puts stdout "No changes detected in $projectdir/src/doc tree" + } + } else { + #no previous completion-record for this target - must assume changed - no need to trigger checksumming + puts stdout "No existing record of doc build in .punkcheck. Assume it needs to be rebuilt." + } + + + $event destroy + $installer destroy + + cd $original_wd + } + proc validate {} { + set projectdir [punk::repo::find_project] + if {$projectdir eq ""} { + puts stderr "No current project dir - unable to check doc status" + return + } + if {![file exists $projectdir/src/doc]} { + set result "No documentation source found. Expected .man files in doctools format at $projectdir/src/doc" + return $result + } + set original_wd [pwd] + cd $projectdir/src + + punk::mix::cli::lib::kettle_call lib validate-doc + + cd $original_wd + } + + namespace eval collection { + variable pkg + set pkg punk::mix::commandset::doc + + namespace export * + namespace path [namespace parent] + + } + + namespace eval lib { + variable pkg + set pkg punk::mix::commandset::doc + + } +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::commandset::doc [namespace eval punk::mix::commandset::doc { + variable pkg punk::mix::commandset::doc + variable version + set version 999999.0a1.0 +}] +return \ No newline at end of file diff --git a/src/modules/punk/mix/commandset/doc-buildversion.txt b/src/modules/punk/mix/commandset/doc-buildversion.txt new file mode 100644 index 00000000..f47d01c8 --- /dev/null +++ b/src/modules/punk/mix/commandset/doc-buildversion.txt @@ -0,0 +1,3 @@ +0.1.0 +#First line must be a semantic version number +#all other lines are ignored. 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 ea44281a..bb370510 100644 --- a/src/modules/punk/mix/commandset/layout-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/layout-999999.0a1.0.tm @@ -68,7 +68,7 @@ namespace eval punk::mix::commandset::layout { #layout collection functions - to be imported with punk::overlay::import_commandset separately namespace eval collection { namespace export * - proc layouts {{glob {}}} { + proc _default {{glob {}}} { if {![string length $glob]} { set glob * } 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 90a00a45..05798576 100644 --- a/src/modules/punk/mix/commandset/module-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/module-999999.0a1.0.tm @@ -102,6 +102,7 @@ namespace eval punk::mix::commandset::module { return $table } + #return all module templates with repeated ones suffixed with .2 .3 etc proc templates_dict {args} { tailcall lib::templates_dict {*}$args } @@ -186,8 +187,8 @@ namespace eval punk::mix::commandset::module { set opt_license [dict get $opts -license] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_template [dict get $opts -template] - set lib_tpldir [file join [punk::mix::cli::lib::mix_templates_dir] module];#fallback for modulename_buildversion.txt, modulename_description.txt - set templates_dict [templates_dict] + + set templates_dict [templates_dict] ;#possibly suffixed with .2 .3 etc #todo - allow versionless name - pick latest which isn't suffixed with .2 etc if {![dict exists $templates_dict $opt_template]} { error "module.new unable to find template '$opt_template'. Known templates: [dict keys $templates_dict]" @@ -283,9 +284,12 @@ namespace eval punk::mix::commandset::module { error $errmsg } + if {[file exists $tpldir/modulename_buildversion.txt]} { set fd [open $tpldir/modulename_buildversion.txt r]; set buildversion_filedata [read $fd]; close $fd } else { + #mix_templates_dir warns of deprecation - review + set lib_tpldir [file join [punk::mix::cli::lib::mix_templates_dir] modules];#fallback for modulename_buildversion.txt, modulename_description.txt set fd [open $lib_tpldir/modulename_buildversion.txt r]; set buildversion_filedata [read $fd]; close $fd } set buildversionfile [file join $modulefolder ${moduletail}-buildversion.txt] diff --git a/src/modules/punk/mix/commandset/project-999999.0a1.0.tm b/src/modules/punk/mix/commandset/project-999999.0a1.0.tm index 61107a51..50678745 100644 --- a/src/modules/punk/mix/commandset/project-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/project-999999.0a1.0.tm @@ -242,44 +242,40 @@ namespace eval punk::mix::commandset::project { set layout_dir $templatebase/layouts/$opt_layout puts stdout ">>> about to call punkcheck::install $layout_dir $projectdir" set resultdict [dict create] - #In this case we need to override the default dir antiglob - as .fossil- folders need to be installed from template - ## default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"] - set override_antiglob_dir_core [list #* _aside .git] set unpublish [list\ src/doc/*\ src/doc/include/*\ ] + + #default antiglob_dir_core will stop .fossil* from being updated - which is generally desirable as these are likely to be customized if {$opt_force} { - set resultdict [punkcheck::install $layout_dir $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite ALL-TARGETS -unpublish_paths $unpublish] + puts stdout "copying layout files - with force applied - overwrite all-targets" + set resultdict [punkcheck::install $layout_dir $projectdir -installer project.new -overwrite ALL-TARGETS -unpublish_paths $unpublish] #file copy -force $layout_dir $projectdir } else { - set resultdict [punkcheck::install $layout_dir $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite installedsourcechanged-targets -unpublish_paths $unpublish] - } - if {[dict size $resultdict]} { - set copied [dict get $resultdict files_copied] - set sources_unchanged [dict get $resultdict sources_unchanged] - puts stdout "--------------------------" - flush stdout - puts stderr "Copied [llength $copied] files from $layout_dir to $projectdir" - foreach f $copied { - puts stdout "COPIED $f" - } - puts stdout "[llength $sources_unchanged] unchanged source files" - puts stdout "--------------------------" - } - set resultdict [punkcheck::install $layout_dir/src/doc $projectdir/src/doc -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite NO-TARGETS] - if {[dict size $resultdict]} { - set copied [dict get $resultdict files_copied] - set files_skipped [dict get $resultdict files_skipped] - puts stdout "--------------------------" - flush stdout - puts stderr "Copied [llength $copied] doc files from $layout_dir/src/doc to $projectdir/src/doc" - foreach f $copied { - puts stdout "COPIED $f" - } - puts stdout "[llength $files_skipped] skipped files" - puts stdout "--------------------------" + puts stdout "copying layout files - (if source file changed)" + set resultdict [punkcheck::install $layout_dir $projectdir -installer project.new -overwrite installedsourcechanged-targets -unpublish_paths $unpublish] } + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + + puts stdout "copying layout src/doc files (if target missing)" + set resultdict [punkcheck::install $layout_dir/src/doc $projectdir/src/doc -punkcheck_folder $projectdir -installer project.new -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + + #target folders .fossil-custom and .fossil-settings may not exist. use -createdir 1 to ensure existence. + #In this case we need to override the default dir antiglob - as .fossil-xxx folders need to be installed from template if missing, or if target is uncustomized. + ## default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"] + set override_antiglob_dir_core [list #* _aside .git] + puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)" + set resultdict [punkcheck::install $layout_dir/.fossil-custom $projectdir/.fossil-custom -createdir 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + + puts stdout "copying layout src/.fossil-settings files (if target missing or uncustomised)" + set resultdict [punkcheck::install $layout_dir/.fossil-settings $projectdir/.fossil-settings -createdir 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + + + #lappend substfiles $projectdir/README.md #lappend substfiles $projectdir/src/README.md @@ -328,8 +324,37 @@ namespace eval punk::mix::commandset::project { #generate www/man/md output in 'embedded' folder which should be checked into repo for online documentation if {[file exists $projectdir/src]} { cd $projectdir/src - punk::mix::cli::lib::kettle_call lib doc - #Kettle doc + #---------- + set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] + $installer set_source_target $projectdir/src/doc $projectdir/src/embedded + set event [$installer start_event {-install_step kettledoc}] + $event targetset_init VIRTUAL kettle_build_doc ;#VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated + $event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source + #---------- + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + } { + $event targetset_started + # -- --- --- --- --- --- + puts stdout "BUILDING DOCS at src/embedded from src/doc" + if {[catch { + + punk::mix::cli::lib::kettle_call lib doc + #Kettle doc + + } errM]} { + $event targetset_end FAILED -note "kettle_build_doc failed: $errM" + } else { + $event targetset_end OK + } + # -- --- --- --- --- --- + } else { + puts stderr "No change detected in src/doc" + $event targetset_end SKIPPED + } + $event end + $event destroy + $installer destroy } cd $projectdir @@ -386,7 +411,8 @@ namespace eval punk::mix::commandset::project { namespace export * namespace path [namespace parent] - proc projects {{glob {}} args} { + #e.g imported as 'projects' + proc _default {{glob {}} args} { package require overtype set db_projects [lib::get_projects $glob] set col1items [lsearch -all -inline -index 0 -subindices $db_projects *] @@ -414,7 +440,7 @@ namespace eval punk::mix::commandset::project { return $msg #return [list_as_lines [lib::get_projects $glob]] } - proc projects.detail {{glob {}} args} { + proc detail {{glob {}} args} { package require overtype package require textutil set defaults [dict create\ @@ -533,11 +559,11 @@ namespace eval punk::mix::commandset::project { return $msg #return [list_as_lines [lib::get_projects $glob]] } - proc projects.cd {{glob {}} args} { + proc cd {{glob {}} args} { dict set args -cd 1 - projects.work $glob {*}$args + work $glob {*}$args } - proc projects.work {{glob {}} args} { + proc work {{glob {}} args} { package require sqlite3 set db_projects [lib::get_projects $glob] #list of lists of the form: @@ -586,11 +612,22 @@ namespace eval punk::mix::commandset::project { set dupid "" } if {$dbcount == 1} { - sqlite3 fdb $fosdb - set pname [lindex [fdb eval {select value from config where name = 'project-name'}] 0] - set pcode [lindex [fdb eval {select value from config where name = 'project-code'}] 0] - fdb close - dict set fosdb_cache $fosdb [list name $pname code $pcode] + set pname "" + set pcode "" + if {[file exists $fosdb]} { + if {[catch { + sqlite3 fdb $fosdb + set pname [lindex [fdb eval {select value from config where name = 'project-name'}] 0] + set pcode [lindex [fdb eval {select value from config where name = 'project-code'}] 0] + fdb close + dict set fosdb_cache $fosdb [list name $pname code $pcode] + } errM]} { + puts stderr "!!! problem with fossil db: $fosdb when examining workdir $wd" + puts stderr "!!! error: $errM" + } + } else { + puts stderr "!!! missing fossil db $fosdb" + } } else { set info [dict get $fosdb_cache $fosdb] lassign $info _name pname _code pcode @@ -704,8 +741,13 @@ namespace eval punk::mix::commandset::project { if {$numrows == 1} { set workingdir [lindex $workdirs 0] puts stdout "1 result. Changing dir to $workingdir" - cd $workingdir - return $workingdir + if {[file exists $workingdir]} { + cd $workingdir + return $workingdir + } else { + puts stderr "path $workingdir doesn't appear to exist" + return [pwd] + } } else { set answer [util::askuser "Change directory to working folder - select a number from 1 to [llength $col_rowids] or any other key to cancel."] if {[string trim $answer] in $col_rowids} { diff --git a/src/modules/punk/mix/templates/layouts/project/.gitignore b/src/modules/punk/mix/templates/layouts/project/.gitignore index 4d6b6912..3aaba3c7 100644 --- a/src/modules/punk/mix/templates/layouts/project/.gitignore +++ b/src/modules/punk/mix/templates/layouts/project/.gitignore @@ -35,6 +35,7 @@ _FOSSIL_ #miscellaneous editor files etc *.swp +.punkcheck todo.txt diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/include_modules.config b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/include_modules.config new file mode 100644 index 00000000..d8eb8c9a --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/include_modules.config @@ -0,0 +1,6 @@ +## e.g +#set bootsupport_modules [list\ +# src/vendormodules cksum\ +# modules punkcheck\ +#] + diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/cksum-1.1.4.tm b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/cksum-1.1.4.tm new file mode 100644 index 00000000..0fb17981 --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/cksum-1.1.4.tm @@ -0,0 +1,200 @@ +# cksum.tcl - Copyright (C) 2002 Pat Thoyts +# +# Provides a Tcl only implementation of the unix cksum(1) command. This is +# similar to the sum(1) command but the algorithm is better defined and +# standardized across multiple platforms by POSIX 1003.2/D11.2 +# +# This command has been verified against the cksum command from the GNU +# textutils package version 2.0 +# +# ------------------------------------------------------------------------- +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ------------------------------------------------------------------------- + +package require Tcl 8.5-; # tcl minimum version + +namespace eval ::crc { + namespace export cksum + + variable cksum_tbl [list 0x0 \ + 0x04C11DB7 0x09823B6E 0x0D4326D9 0x130476DC 0x17C56B6B \ + 0x1A864DB2 0x1E475005 0x2608EDB8 0x22C9F00F 0x2F8AD6D6 \ + 0x2B4BCB61 0x350C9B64 0x31CD86D3 0x3C8EA00A 0x384FBDBD \ + 0x4C11DB70 0x48D0C6C7 0x4593E01E 0x4152FDA9 0x5F15ADAC \ + 0x5BD4B01B 0x569796C2 0x52568B75 0x6A1936C8 0x6ED82B7F \ + 0x639B0DA6 0x675A1011 0x791D4014 0x7DDC5DA3 0x709F7B7A \ + 0x745E66CD 0x9823B6E0 0x9CE2AB57 0x91A18D8E 0x95609039 \ + 0x8B27C03C 0x8FE6DD8B 0x82A5FB52 0x8664E6E5 0xBE2B5B58 \ + 0xBAEA46EF 0xB7A96036 0xB3687D81 0xAD2F2D84 0xA9EE3033 \ + 0xA4AD16EA 0xA06C0B5D 0xD4326D90 0xD0F37027 0xDDB056FE \ + 0xD9714B49 0xC7361B4C 0xC3F706FB 0xCEB42022 0xCA753D95 \ + 0xF23A8028 0xF6FB9D9F 0xFBB8BB46 0xFF79A6F1 0xE13EF6F4 \ + 0xE5FFEB43 0xE8BCCD9A 0xEC7DD02D 0x34867077 0x30476DC0 \ + 0x3D044B19 0x39C556AE 0x278206AB 0x23431B1C 0x2E003DC5 \ + 0x2AC12072 0x128E9DCF 0x164F8078 0x1B0CA6A1 0x1FCDBB16 \ + 0x018AEB13 0x054BF6A4 0x0808D07D 0x0CC9CDCA 0x7897AB07 \ + 0x7C56B6B0 0x71159069 0x75D48DDE 0x6B93DDDB 0x6F52C06C \ + 0x6211E6B5 0x66D0FB02 0x5E9F46BF 0x5A5E5B08 0x571D7DD1 \ + 0x53DC6066 0x4D9B3063 0x495A2DD4 0x44190B0D 0x40D816BA \ + 0xACA5C697 0xA864DB20 0xA527FDF9 0xA1E6E04E 0xBFA1B04B \ + 0xBB60ADFC 0xB6238B25 0xB2E29692 0x8AAD2B2F 0x8E6C3698 \ + 0x832F1041 0x87EE0DF6 0x99A95DF3 0x9D684044 0x902B669D \ + 0x94EA7B2A 0xE0B41DE7 0xE4750050 0xE9362689 0xEDF73B3E \ + 0xF3B06B3B 0xF771768C 0xFA325055 0xFEF34DE2 0xC6BCF05F \ + 0xC27DEDE8 0xCF3ECB31 0xCBFFD686 0xD5B88683 0xD1799B34 \ + 0xDC3ABDED 0xD8FBA05A 0x690CE0EE 0x6DCDFD59 0x608EDB80 \ + 0x644FC637 0x7A089632 0x7EC98B85 0x738AAD5C 0x774BB0EB \ + 0x4F040D56 0x4BC510E1 0x46863638 0x42472B8F 0x5C007B8A \ + 0x58C1663D 0x558240E4 0x51435D53 0x251D3B9E 0x21DC2629 \ + 0x2C9F00F0 0x285E1D47 0x36194D42 0x32D850F5 0x3F9B762C \ + 0x3B5A6B9B 0x0315D626 0x07D4CB91 0x0A97ED48 0x0E56F0FF \ + 0x1011A0FA 0x14D0BD4D 0x19939B94 0x1D528623 0xF12F560E \ + 0xF5EE4BB9 0xF8AD6D60 0xFC6C70D7 0xE22B20D2 0xE6EA3D65 \ + 0xEBA91BBC 0xEF68060B 0xD727BBB6 0xD3E6A601 0xDEA580D8 \ + 0xDA649D6F 0xC423CD6A 0xC0E2D0DD 0xCDA1F604 0xC960EBB3 \ + 0xBD3E8D7E 0xB9FF90C9 0xB4BCB610 0xB07DABA7 0xAE3AFBA2 \ + 0xAAFBE615 0xA7B8C0CC 0xA379DD7B 0x9B3660C6 0x9FF77D71 \ + 0x92B45BA8 0x9675461F 0x8832161A 0x8CF30BAD 0x81B02D74 \ + 0x857130C3 0x5D8A9099 0x594B8D2E 0x5408ABF7 0x50C9B640 \ + 0x4E8EE645 0x4A4FFBF2 0x470CDD2B 0x43CDC09C 0x7B827D21 \ + 0x7F436096 0x7200464F 0x76C15BF8 0x68860BFD 0x6C47164A \ + 0x61043093 0x65C52D24 0x119B4BE9 0x155A565E 0x18197087 \ + 0x1CD86D30 0x029F3D35 0x065E2082 0x0B1D065B 0x0FDC1BEC \ + 0x3793A651 0x3352BBE6 0x3E119D3F 0x3AD08088 0x2497D08D \ + 0x2056CD3A 0x2D15EBE3 0x29D4F654 0xC5A92679 0xC1683BCE \ + 0xCC2B1D17 0xC8EA00A0 0xD6AD50A5 0xD26C4D12 0xDF2F6BCB \ + 0xDBEE767C 0xE3A1CBC1 0xE760D676 0xEA23F0AF 0xEEE2ED18 \ + 0xF0A5BD1D 0xF464A0AA 0xF9278673 0xFDE69BC4 0x89B8FD09 \ + 0x8D79E0BE 0x803AC667 0x84FBDBD0 0x9ABC8BD5 0x9E7D9662 \ + 0x933EB0BB 0x97FFAD0C 0xAFB010B1 0xAB710D06 0xA6322BDF \ + 0xA2F33668 0xBCB4666D 0xB8757BDA 0xB5365D03 0xB1F740B4 ] + + variable uid + if {![info exists uid]} {set uid 0} +} + +# crc::CksumInit -- +# +# Create and initialize a cksum context. This is cleaned up when we +# call CksumFinal to obtain the result. +# +proc ::crc::CksumInit {} { + variable uid + set token [namespace current]::[incr uid] + upvar #0 $token state + array set state {t 0 l 0} + return $token +} + +proc ::crc::CksumUpdate {token data} { + variable cksum_tbl + upvar #0 $token state + set t $state(t) + binary scan $data c* r + foreach {n} $r { + set index [expr { (($t >> 24) ^ ($n & 0xFF)) & 0xFF }] + # Since the introduction of built-in bigInt support with Tcl + # 8.5, bit-shifting $t to the left no longer overflows, + # keeping it 32 bits long. The value grows bigger and bigger + # instead - a severe hit on performance. For this reason we + # do a bitwise AND against 0xFFFFFFFF at each step to keep the + # value within limits. + set t [expr {0xFFFFFFFF & (($t << 8) ^ [lindex $cksum_tbl $index])}] + incr state(l) + } + set state(t) $t + return +} + +proc ::crc::CksumFinal {token} { + variable cksum_tbl + upvar #0 $token state + set t $state(t) + for {set i $state(l)} {$i > 0} {set i [expr {$i>>8}]} { + set index [expr {(($t >> 24) ^ $i) & 0xFF}] + set t [expr {0xFFFFFFFF & (($t << 8) ^ [lindex $cksum_tbl $index])}] + } + unset state + return [expr {~$t & 0xFFFFFFFF}] +} + +# crc::Pop -- +# +# Pop the nth element off a list. Used in options processing. +# +proc ::crc::Pop {varname {nth 0}} { + upvar $varname args + set r [lindex $args $nth] + set args [lreplace $args $nth $nth] + return $r +} + +# Description: +# Provide a Tcl equivalent of the unix cksum(1) command. +# Options: +# -filename name - return a checksum for the specified file. +# -format string - return the checksum using this format string. +# -chunksize size - set the chunking read size +# +proc ::crc::cksum {args} { + array set opts [list -filename {} -channel {} -chunksize 4096 \ + -format %u -command {}] + while {[string match -* [set option [lindex $args 0]]]} { + switch -glob -- $option { + -file* { set opts(-filename) [Pop args 1] } + -chan* { set opts(-channel) [Pop args 1] } + -chunk* { set opts(-chunksize) [Pop args 1] } + -for* { set opts(-format) [Pop args 1] } + -command { set opts(-command) [Pop args 1] } + default { + if {[llength $args] == 1} { break } + if {[string compare $option "--"] == 0} { Pop args ; break } + set err [join [lsort [array names opts -*]] ", "] + return -code error "bad option \"option\": must be $err" + } + } + Pop args + } + + if {$opts(-filename) != {}} { + set opts(-channel) [open $opts(-filename) r] + fconfigure $opts(-channel) -translation binary + } + + if {$opts(-channel) == {}} { + + if {[llength $args] != 1} { + return -code error "wrong # args: should be\ + cksum ?-format string?\ + -channel chan | -filename file | string" + } + set tok [CksumInit] + CksumUpdate $tok [lindex $args 0] + set r [CksumFinal $tok] + + } else { + + set tok [CksumInit] + while {![eof $opts(-channel)]} { + CksumUpdate $tok [read $opts(-channel) $opts(-chunksize)] + } + set r [CksumFinal $tok] + + if {$opts(-filename) != {}} { + close $opts(-channel) + } + } + + return [format $opts(-format) $r] +} + +# ------------------------------------------------------------------------- + +package provide cksum 1.1.4 + +# ------------------------------------------------------------------------- +# Local variables: +# mode: tcl +# indent-tabs-mode: nil +# End: diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/cmdline-1.5.2.tm b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/cmdline-1.5.2.tm new file mode 100644 index 00000000..4e5e1df9 --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/cmdline-1.5.2.tm @@ -0,0 +1,933 @@ +# cmdline.tcl -- +# +# This package provides a utility for parsing command line +# arguments that are processed by our various applications. +# It also includes a utility routine to determine the +# application name for use in command line errors. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright (c) 2001-2015 by Andreas Kupries . +# Copyright (c) 2003 by David N. Welton +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require Tcl 8.5- +package provide cmdline 1.5.2 + +namespace eval ::cmdline { + namespace export getArgv0 getopt getKnownOpt getfiles getoptions \ + getKnownOptions usage +} + +# ::cmdline::getopt -- +# +# The cmdline::getopt works in a fashion like the standard +# C based getopt function. Given an option string and a +# pointer to an array or args this command will process the +# first argument and return info on how to proceed. +# +# Arguments: +# argvVar Name of the argv list that you +# want to process. If options are found the +# arg list is modified and the processed arguments +# are removed from the start of the list. +# optstring A list of command options that the application +# will accept. If the option ends in ".arg" the +# getopt routine will use the next argument as +# an argument to the option. Otherwise the option +# is a boolean that is set to 1 if present. +# optVar The variable pointed to by optVar +# contains the option that was found (without the +# leading '-' and without the .arg extension). +# valVar Upon success, the variable pointed to by valVar +# contains the value for the specified option. +# This value comes from the command line for .arg +# options, otherwise the value is 1. +# If getopt fails, the valVar is filled with an +# error message. +# +# Results: +# The getopt function returns 1 if an option was found, 0 if no more +# options were found, and -1 if an error occurred. + +proc ::cmdline::getopt {argvVar optstring optVar valVar} { + upvar 1 $argvVar argsList + upvar 1 $optVar option + upvar 1 $valVar value + + set result [getKnownOpt argsList $optstring option value] + + if {$result < 0} { + # Collapse unknown-option error into any-other-error result. + set result -1 + } + return $result +} + +# ::cmdline::getKnownOpt -- +# +# The cmdline::getKnownOpt works in a fashion like the standard +# C based getopt function. Given an option string and a +# pointer to an array or args this command will process the +# first argument and return info on how to proceed. +# +# Arguments: +# argvVar Name of the argv list that you +# want to process. If options are found the +# arg list is modified and the processed arguments +# are removed from the start of the list. Note that +# unknown options and the args that follow them are +# left in this list. +# optstring A list of command options that the application +# will accept. If the option ends in ".arg" the +# getopt routine will use the next argument as +# an argument to the option. Otherwise the option +# is a boolean that is set to 1 if present. +# optVar The variable pointed to by optVar +# contains the option that was found (without the +# leading '-' and without the .arg extension). +# valVar Upon success, the variable pointed to by valVar +# contains the value for the specified option. +# This value comes from the command line for .arg +# options, otherwise the value is 1. +# If getopt fails, the valVar is filled with an +# error message. +# +# Results: +# The getKnownOpt function returns 1 if an option was found, +# 0 if no more options were found, -1 if an unknown option was +# encountered, and -2 if any other error occurred. + +proc ::cmdline::getKnownOpt {argvVar optstring optVar valVar} { + upvar 1 $argvVar argsList + upvar 1 $optVar option + upvar 1 $valVar value + + # default settings for a normal return + set value "" + set option "" + set result 0 + + # check if we're past the end of the args list + if {[llength $argsList] != 0} { + + # if we got -- or an option that doesn't begin with -, return (skipping + # the --). otherwise process the option arg. + switch -glob -- [set arg [lindex $argsList 0]] { + "--" { + set argsList [lrange $argsList 1 end] + } + "--*" - + "-*" { + set option [string range $arg 1 end] + if {[string equal [string range $option 0 0] "-"]} { + set option [string range $arg 2 end] + } + + # support for format: [-]-option=value + set idx [string first "=" $option 1] + if {$idx != -1} { + set _val [string range $option [expr {$idx+1}] end] + set option [string range $option 0 [expr {$idx-1}]] + } + + if {[lsearch -exact $optstring $option] != -1} { + # Booleans are set to 1 when present + set value 1 + set result 1 + set argsList [lrange $argsList 1 end] + } elseif {[lsearch -exact $optstring "$option.arg"] != -1} { + set result 1 + set argsList [lrange $argsList 1 end] + + if {[info exists _val]} { + set value $_val + } elseif {[llength $argsList]} { + set value [lindex $argsList 0] + set argsList [lrange $argsList 1 end] + } else { + set value "Option \"$option\" requires an argument" + set result -2 + } + } else { + # Unknown option. + set value "Illegal option \"-$option\"" + set result -1 + } + } + default { + # Skip ahead + } + } + } + + return $result +} + +# ::cmdline::getoptions -- +# +# Process a set of command line options, filling in defaults +# for those not specified. This also generates an error message +# that lists the allowed flags if an incorrect flag is specified. +# +# Arguments: +# argvVar The name of the argument list, typically argv. +# We remove all known options and their args from it. +# In other words, after the call to this command the +# referenced variable contains only the non-options, +# and unknown options. +# optlist A list-of-lists where each element specifies an option +# in the form: +# (where flag takes no argument) +# flag comment +# +# (or where flag takes an argument) +# flag default comment +# +# If flag ends in ".arg" then the value is taken from the +# command line. Otherwise it is a boolean and appears in +# the result if present on the command line. If flag ends +# in ".secret", it will not be displayed in the usage. +# usage Text to include in the usage display. Defaults to +# "options:" +# +# Results +# Name value pairs suitable for using with array set. +# A modified `argvVar`. + +proc ::cmdline::getoptions {argvVar optlist {usage options:}} { + upvar 1 $argvVar argv + + set opts [GetOptionDefaults $optlist result] + + set argc [llength $argv] + while {[set err [getopt argv $opts opt arg]]} { + if {$err < 0} { + set result(?) "" + break + } + set result($opt) $arg + } + if {[info exist result(?)] || [info exists result(help)]} { + Error [usage $optlist $usage] USAGE + } + return [array get result] +} + +# ::cmdline::getKnownOptions -- +# +# Process a set of command line options, filling in defaults +# for those not specified. This ignores unknown flags, but generates +# an error message that lists the correct usage if a known option +# is used incorrectly. +# +# Arguments: +# argvVar The name of the argument list, typically argv. This +# We remove all known options and their args from it. +# In other words, after the call to this command the +# referenced variable contains only the non-options, +# and unknown options. +# optlist A list-of-lists where each element specifies an option +# in the form: +# flag default comment +# If flag ends in ".arg" then the value is taken from the +# command line. Otherwise it is a boolean and appears in +# the result if present on the command line. If flag ends +# in ".secret", it will not be displayed in the usage. +# usage Text to include in the usage display. Defaults to +# "options:" +# +# Results +# Name value pairs suitable for using with array set. +# A modified `argvVar`. + +proc ::cmdline::getKnownOptions {argvVar optlist {usage options:}} { + upvar 1 $argvVar argv + + set opts [GetOptionDefaults $optlist result] + + # As we encounter them, keep the unknown options and their + # arguments in this list. Before we return from this procedure, + # we'll prepend these args to the argList so that the application + # doesn't lose them. + + set unknownOptions [list] + + set argc [llength $argv] + while {[set err [getKnownOpt argv $opts opt arg]]} { + if {$err == -1} { + # Unknown option. + + # Skip over any non-option items that follow it. + # For now, add them to the list of unknownOptions. + lappend unknownOptions [lindex $argv 0] + set argv [lrange $argv 1 end] + while {([llength $argv] != 0) \ + && ![string match "-*" [lindex $argv 0]]} { + lappend unknownOptions [lindex $argv 0] + set argv [lrange $argv 1 end] + } + } elseif {$err == -2} { + set result(?) "" + break + } else { + set result($opt) $arg + } + } + + # Before returning, prepend the any unknown args back onto the + # argList so that the application doesn't lose them. + set argv [concat $unknownOptions $argv] + + if {[info exist result(?)] || [info exists result(help)]} { + Error [usage $optlist $usage] USAGE + } + return [array get result] +} + +# ::cmdline::GetOptionDefaults -- +# +# This internal procedure processes the option list (that was passed to +# the getopt or getKnownOpt procedure). The defaultArray gets an index +# for each option in the option list, the value of which is the option's +# default value. +# +# Arguments: +# optlist A list-of-lists where each element specifies an option +# in the form: +# flag default comment +# If flag ends in ".arg" then the value is taken from the +# command line. Otherwise it is a boolean and appears in +# the result if present on the command line. If flag ends +# in ".secret", it will not be displayed in the usage. +# defaultArrayVar The name of the array in which to put argument defaults. +# +# Results +# Name value pairs suitable for using with array set. + +proc ::cmdline::GetOptionDefaults {optlist defaultArrayVar} { + upvar 1 $defaultArrayVar result + + set opts {? help} + foreach opt $optlist { + set name [lindex $opt 0] + if {[regsub -- {\.secret$} $name {} name] == 1} { + # Need to hide this from the usage display and getopt + } + lappend opts $name + if {[regsub -- {\.arg$} $name {} name] == 1} { + + # Set defaults for those that take values. + + set default [lindex $opt 1] + set result($name) $default + } else { + # The default for booleans is false + set result($name) 0 + } + } + return $opts +} + +# ::cmdline::usage -- +# +# Generate an error message that lists the allowed flags. +# +# Arguments: +# optlist As for cmdline::getoptions +# usage Text to include in the usage display. Defaults to +# "options:" +# +# Results +# A formatted usage message + +proc ::cmdline::usage {optlist {usage {options:}}} { + set str "[getArgv0] $usage\n" + set longest 20 + set lines {} + foreach opt [concat $optlist \ + {{- "Forcibly stop option processing"} {help "Print this message"} {? "Print this message"}}] { + set name "-[lindex $opt 0]" + if {[regsub -- {\.secret$} $name {} name] == 1} { + # Hidden option + continue + } + if {[regsub -- {\.arg$} $name {} name] == 1} { + append name " value" + set desc "[lindex $opt 2] <[lindex $opt 1]>" + } else { + set desc "[lindex $opt 1]" + } + set n [string length $name] + if {$n > $longest} { set longest $n } + # max not available before 8.5 - set longest [expr {max($longest, )}] + lappend lines $name $desc + } + foreach {name desc} $lines { + append str "[string trimright [format " %-*s %s" $longest $name $desc]]\n" + } + + return $str +} + +# ::cmdline::getfiles -- +# +# Given a list of file arguments from the command line, compute +# the set of valid files. On windows, file globbing is performed +# on each argument. On Unix, only file existence is tested. If +# a file argument produces no valid files, a warning is optionally +# generated. +# +# This code also uses the full path for each file. If not +# given it prepends [pwd] to the filename. This ensures that +# these files will never conflict with files in our zip file. +# +# Arguments: +# patterns The file patterns specified by the user. +# quiet If this flag is set, no warnings will be generated. +# +# Results: +# Returns the list of files that match the input patterns. + +proc ::cmdline::getfiles {patterns quiet} { + set result {} + if {$::tcl_platform(platform) == "windows"} { + foreach pattern $patterns { + set pat [file join $pattern] + set files [glob -nocomplain -- $pat] + if {$files == {}} { + if {! $quiet} { + puts stdout "warning: no files match \"$pattern\"" + } + } else { + foreach file $files { + lappend result $file + } + } + } + } else { + set result $patterns + } + set files {} + foreach file $result { + # Make file an absolute path so that we will never conflict + # with files that might be contained in our zip file. + set fullPath [file join [pwd] $file] + + if {[file isfile $fullPath]} { + lappend files $fullPath + } elseif {! $quiet} { + puts stdout "warning: no files match \"$file\"" + } + } + return $files +} + +# ::cmdline::getArgv0 -- +# +# This command returns the "sanitized" version of argv0. It will strip +# off the leading path and remove the ".bin" extensions that our apps +# use because they must be wrapped by a shell script. +# +# Arguments: +# None. +# +# Results: +# The application name that can be used in error messages. + +proc ::cmdline::getArgv0 {} { + global argv0 + + set name [file tail $argv0] + return [file rootname $name] +} + +## +# ### ### ### ######### ######### ######### +## +# Now the typed versions of the above commands. +## +# ### ### ### ######### ######### ######### +## + +# typedCmdline.tcl -- +# +# This package provides a utility for parsing typed command +# line arguments that may be processed by various applications. +# +# Copyright (c) 2000 by Ross Palmer Mohn. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: cmdline.tcl,v 1.28 2011/02/23 17:41:52 andreas_kupries Exp $ + +namespace eval ::cmdline { + namespace export typedGetopt typedGetoptions typedUsage + + # variable cmdline::charclasses -- + # + # Create regexp list of allowable character classes + # from "string is" error message. + # + # Results: + # String of character class names separated by "|" characters. + + variable charclasses + #checker exclude badKey + catch {string is . .} charclasses + variable dummy + regexp -- {must be (.+)$} $charclasses dummy charclasses + regsub -all -- {, (or )?} $charclasses {|} charclasses + unset dummy +} + +# ::cmdline::typedGetopt -- +# +# The cmdline::typedGetopt works in a fashion like the standard +# C based getopt function. Given an option string and a +# pointer to a list of args this command will process the +# first argument and return info on how to proceed. In addition, +# you may specify a type for the argument to each option. +# +# Arguments: +# argvVar Name of the argv list that you want to process. +# If options are found, the arg list is modified +# and the processed arguments are removed from the +# start of the list. +# +# optstring A list of command options that the application +# will accept. If the option ends in ".xxx", where +# xxx is any valid character class to the tcl +# command "string is", then typedGetopt routine will +# use the next argument as a typed argument to the +# option. The argument must match the specified +# character classes (e.g. integer, double, boolean, +# xdigit, etc.). Alternatively, you may specify +# ".arg" for an untyped argument. +# +# optVar Upon success, the variable pointed to by optVar +# contains the option that was found (without the +# leading '-' and without the .xxx extension). If +# typedGetopt fails the variable is set to the empty +# string. SOMETIMES! Different for each -value! +# +# argVar Upon success, the variable pointed to by argVar +# contains the argument for the specified option. +# If typedGetopt fails, the variable is filled with +# an error message. +# +# Argument type syntax: +# Option that takes no argument. +# foo +# +# Option that takes a typeless argument. +# foo.arg +# +# Option that takes a typed argument. Allowable types are all +# valid character classes to the tcl command "string is". +# Currently must be one of alnum, alpha, ascii, control, +# boolean, digit, double, false, graph, integer, lower, print, +# punct, space, true, upper, wordchar, or xdigit. +# foo.double +# +# Option that takes an argument from a list. +# foo.(bar|blat) +# +# Argument quantifier syntax: +# Option that takes an optional argument. +# foo.arg? +# +# Option that takes a list of arguments terminated by "--". +# foo.arg+ +# +# Option that takes an optional list of arguments terminated by "--". +# foo.arg* +# +# Argument quantifiers work on all argument types, so, for +# example, the following is a valid option specification. +# foo.(bar|blat|blah)? +# +# Argument syntax miscellany: +# Options may be specified on the command line using a unique, +# shortened version of the option name. Given that program foo +# has an option list of {bar.alpha blah.arg blat.double}, +# "foo -b fob" returns an error, but "foo -ba fob" +# successfully returns {bar fob} +# +# Results: +# The typedGetopt function returns one of the following: +# 1 a valid option was found +# 0 no more options found to process +# -1 invalid option +# -2 missing argument to a valid option +# -3 argument to a valid option does not match type +# +# Known Bugs: +# When using options which include special glob characters, +# you must use the exact option. Abbreviating it can cause +# an error in the "cmdline::prefixSearch" procedure. + +proc ::cmdline::typedGetopt {argvVar optstring optVar argVar} { + variable charclasses + + upvar $argvVar argsList + + upvar $optVar retvar + upvar $argVar optarg + + # default settings for a normal return + set optarg "" + set retvar "" + set retval 0 + + # check if we're past the end of the args list + if {[llength $argsList] != 0} { + + # if we got -- or an option that doesn't begin with -, return (skipping + # the --). otherwise process the option arg. + switch -glob -- [set arg [lindex $argsList 0]] { + "--" { + set argsList [lrange $argsList 1 end] + } + + "-*" { + # Create list of options without their argument extensions + + set optstr "" + foreach str $optstring { + lappend optstr [file rootname $str] + } + + set _opt [string range $arg 1 end] + + set i [prefixSearch $optstr [file rootname $_opt]] + if {$i != -1} { + set opt [lindex $optstring $i] + + set quantifier "none" + if {[regexp -- {\.[^.]+([?+*])$} $opt dummy quantifier]} { + set opt [string range $opt 0 end-1] + } + + if {[string first . $opt] == -1} { + set retval 1 + set retvar $opt + set argsList [lrange $argsList 1 end] + + } elseif {[regexp -- "\\.(arg|$charclasses)\$" $opt dummy charclass] + || [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} { + if {[string equal arg $charclass]} { + set type arg + } elseif {[regexp -- "^($charclasses)\$" $charclass]} { + set type class + } else { + set type oneof + } + + set argsList [lrange $argsList 1 end] + set opt [file rootname $opt] + + while {1} { + if {[llength $argsList] == 0 + || [string equal "--" [lindex $argsList 0]]} { + if {[string equal "--" [lindex $argsList 0]]} { + set argsList [lrange $argsList 1 end] + } + + set oneof "" + if {$type == "arg"} { + set charclass an + } elseif {$type == "oneof"} { + set oneof ", one of $charclass" + set charclass an + } + + if {$quantifier == "?"} { + set retval 1 + set retvar $opt + set optarg "" + } elseif {$quantifier == "+"} { + set retvar $opt + if {[llength $optarg] < 1} { + set retval -2 + set optarg "Option requires at least one $charclass argument$oneof -- $opt" + } else { + set retval 1 + } + } elseif {$quantifier == "*"} { + set retval 1 + set retvar $opt + } else { + set optarg "Option requires $charclass argument$oneof -- $opt" + set retvar $opt + set retval -2 + } + set quantifier "" + } elseif {($type == "arg") + || (($type == "oneof") + && [string first "|[lindex $argsList 0]|" "|$charclass|"] != -1) + || (($type == "class") + && [string is $charclass [lindex $argsList 0]])} { + set retval 1 + set retvar $opt + lappend optarg [lindex $argsList 0] + set argsList [lrange $argsList 1 end] + } else { + set oneof "" + if {$type == "arg"} { + set charclass an + } elseif {$type == "oneof"} { + set oneof ", one of $charclass" + set charclass an + } + set optarg "Option requires $charclass argument$oneof -- $opt" + set retvar $opt + set retval -3 + + if {$quantifier == "?"} { + set retval 1 + set optarg "" + } + set quantifier "" + } + if {![regexp -- {[+*]} $quantifier]} { + break; + } + } + } else { + Error \ + "Illegal option type specification: must be one of $charclasses" \ + BAD OPTION TYPE + } + } else { + set optarg "Illegal option -- $_opt" + set retvar $_opt + set retval -1 + } + } + default { + # Skip ahead + } + } + } + + return $retval +} + +# ::cmdline::typedGetoptions -- +# +# Process a set of command line options, filling in defaults +# for those not specified. This also generates an error message +# that lists the allowed options if an incorrect option is +# specified. +# +# Arguments: +# argvVar The name of the argument list, typically argv +# optlist A list-of-lists where each element specifies an option +# in the form: +# +# option default comment +# +# Options formatting is as described for the optstring +# argument of typedGetopt. Default is for optionally +# specifying a default value. Comment is for optionally +# specifying a comment for the usage display. The +# options "--", "-help", and "-?" are automatically included +# in optlist. +# +# Argument syntax miscellany: +# Options formatting and syntax is as described in typedGetopt. +# There are two additional suffixes that may be applied when +# passing options to typedGetoptions. +# +# You may add ".multi" as a suffix to any option. For options +# that take an argument, this means that the option may be used +# more than once on the command line and that each additional +# argument will be appended to a list, which is then returned +# to the application. +# foo.double.multi +# +# If a non-argument option is specified as ".multi", it is +# toggled on and off for each time it is used on the command +# line. +# foo.multi +# +# If an option specification does not contain the ".multi" +# suffix, it is not an error to use an option more than once. +# In this case, the behavior for options with arguments is that +# the last argument is the one that will be returned. For +# options that do not take arguments, using them more than once +# has no additional effect. +# +# Options may also be hidden from the usage display by +# appending the suffix ".secret" to any option specification. +# Please note that the ".secret" suffix must be the last suffix, +# after any argument type specification and ".multi" suffix. +# foo.xdigit.multi.secret +# +# Results +# Name value pairs suitable for using with array set. + +proc ::cmdline::typedGetoptions {argvVar optlist {usage options:}} { + variable charclasses + + upvar 1 $argvVar argv + + set opts {? help} + foreach opt $optlist { + set name [lindex $opt 0] + if {[regsub -- {\.secret$} $name {} name] == 1} { + # Remove this extension before passing to typedGetopt. + } + if {[regsub -- {\.multi$} $name {} name] == 1} { + # Remove this extension before passing to typedGetopt. + + regsub -- {\..*$} $name {} temp + set multi($temp) 1 + } + lappend opts $name + if {[regsub -- "\\.(arg|$charclasses|\\(.+).?\$" $name {} name] == 1} { + # Set defaults for those that take values. + # Booleans are set just by being present, or not + + set dflt [lindex $opt 1] + if {$dflt != {}} { + set defaults($name) $dflt + } + } + } + set argc [llength $argv] + while {[set err [typedGetopt argv $opts opt arg]]} { + if {$err == 1} { + if {[info exists result($opt)] + && [info exists multi($opt)]} { + # Toggle boolean options or append new arguments + + if {$arg == ""} { + unset result($opt) + } else { + set result($opt) "$result($opt) $arg" + } + } else { + set result($opt) "$arg" + } + } elseif {($err == -1) || ($err == -3)} { + Error [typedUsage $optlist $usage] USAGE + } elseif {$err == -2 && ![info exists defaults($opt)]} { + Error [typedUsage $optlist $usage] USAGE + } + } + if {[info exists result(?)] || [info exists result(help)]} { + Error [typedUsage $optlist $usage] USAGE + } + foreach {opt dflt} [array get defaults] { + if {![info exists result($opt)]} { + set result($opt) $dflt + } + } + return [array get result] +} + +# ::cmdline::typedUsage -- +# +# Generate an error message that lists the allowed flags, +# type of argument taken (if any), default value (if any), +# and an optional description. +# +# Arguments: +# optlist As for cmdline::typedGetoptions +# +# Results +# A formatted usage message + +proc ::cmdline::typedUsage {optlist {usage {options:}}} { + variable charclasses + + set str "[getArgv0] $usage\n" + set longest 20 + set lines {} + foreach opt [concat $optlist \ + {{help "Print this message"} {? "Print this message"}}] { + set name "-[lindex $opt 0]" + if {[regsub -- {\.secret$} $name {} name] == 1} { + # Hidden option + continue + } + + if {[regsub -- {\.multi$} $name {} name] == 1} { + # Display something about multiple options + } + + if {[regexp -- "\\.(arg|$charclasses)\$" $name dummy charclass] || + [regexp -- {\.\(([^)]+)\)} $opt dummy charclass] + } { + regsub -- "\\..+\$" $name {} name + append name " $charclass" + set desc [lindex $opt 2] + set default [lindex $opt 1] + if {$default != ""} { + append desc " <$default>" + } + } else { + set desc [lindex $opt 1] + } + lappend accum $name $desc + set n [string length $name] + if {$n > $longest} { set longest $n } + # max not available before 8.5 - set longest [expr {max($longest, [string length $name])}] + } + foreach {name desc} $accum { + append str "[string trimright [format " %-*s %s" $longest $name $desc]]\n" + } + return $str +} + +# ::cmdline::prefixSearch -- +# +# Search a Tcl list for a pattern; searches first for an exact match, +# and if that fails, for a unique prefix that matches the pattern +# (i.e, first "lsearch -exact", then "lsearch -glob $pattern*" +# +# Arguments: +# list list of words +# pattern word to search for +# +# Results: +# Index of found word is returned. If no exact match or +# unique short version is found then -1 is returned. + +proc ::cmdline::prefixSearch {list pattern} { + # Check for an exact match + + if {[set pos [::lsearch -exact $list $pattern]] > -1} { + return $pos + } + + # Check for a unique short version + + set slist [lsort $list] + if {[set pos [::lsearch -glob $slist $pattern*]] > -1} { + # What if there is nothing for the check variable? + + set check [lindex $slist [expr {$pos + 1}]] + if {[string first $pattern $check] != 0} { + return [::lsearch -exact $list [lindex $slist $pos]] + } + } + return -1 +} +# ::cmdline::Error -- +# +# Internal helper to throw errors with a proper error-code attached. +# +# Arguments: +# message text of the error message to throw. +# args additional parts of the error code to use, +# with CMDLINE as basic prefix added by this command. +# +# Results: +# An error is thrown, always. + +proc ::cmdline::Error {message args} { + return -code error -errorcode [linsert $args 0 CMDLINE] $message +} diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/fileutil-1.16.1.tm b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/fileutil-1.16.1.tm new file mode 100644 index 00000000..6d5c737e --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/fileutil-1.16.1.tm @@ -0,0 +1,2311 @@ +# fileutil.tcl -- +# +# Tcl implementations of standard UNIX utilities. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright (c) 2002 by Phil Ehrens (fileType) +# Copyright (c) 2005-2013 by Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require Tcl 8.5- +package require cmdline +package provide fileutil 1.16.1 + +namespace eval ::fileutil { + namespace export \ + grep find findByPattern cat touch foreachLine \ + jail stripPwd stripN stripPath tempdir tempfile \ + install fileType writeFile appendToFile \ + insertIntoFile removeFromFile replaceInFile \ + updateInPlace test tempdirReset maketempdir +} + +# ::fileutil::grep -- +# +# Implementation of grep. Adapted from the Tcler's Wiki. +# +# Arguments: +# pattern pattern to search for. +# files list of files to search; if NULL, uses stdin. +# +# Results: +# results list of matches + +proc ::fileutil::grep {pattern {files {}}} { + set result [list] + if {[llength $files] == 0} { + # read from stdin + set lnum 0 + while {[gets stdin line] >= 0} { + incr lnum + if {[regexp -- $pattern $line]} { + lappend result "${lnum}:${line}" + } + } + } else { + foreach filename $files { + set file [open $filename r] + set lnum 0 + while {[gets $file line] >= 0} { + incr lnum + if {[regexp -- $pattern $line]} { + lappend result "${filename}:${lnum}:${line}" + } + } + close $file + } + } + return $result +} + +# ::fileutil::find == + +# Below is the core command, which is portable across Tcl versions and +# platforms. Functionality which is common or platform and/or Tcl +# version dependent, has been factored out/ encapsulated into separate +# (small) commands. Only these commands may have multiple variant +# implementations per the available features of the Tcl core / +# platform. +# +# These commands are +# +# FADD - Add path result, performs filtering. Portable! +# GLOBF - Return files in a directory. Tcl version/platform dependent. +# GLOBD - Return dirs in a directory. Tcl version/platform dependent. +# ACCESS - Check directory for accessibility. Tcl version/platform dependent. + +proc ::fileutil::find {{basedir .} {filtercmd {}}} { + set result {} + set filt [string length $filtercmd] + + if {[file isfile $basedir]} { + # The base is a file, and therefore only possible result, + # modulo filtering. + + FADD $basedir + + } elseif {[file isdirectory $basedir]} { + # For a directory as base we do an iterative recursion through + # the directory hierarchy starting at the base. We use a queue + # (Tcl list) of directories we have to check. We access it by + # index, and stop when we have reached beyond the end of the + # list. This is faster than removing elements from the be- + # ginning of the list, as that entails copying down a possibly + # large list of directories, making it O(n*n). The index is + # faster, O(n), at the expense of memory. Nothing is deleted + # from the list until we have processed all directories in the + # hierarchy. + # + # We scan each directory at least twice. First for files, then + # for directories. The scans may internally make several + # passes (normal vs hidden files). + # + # Looped directory structures due to symbolic links are + # handled by _fully_ normalizing directory paths and checking + # if we encountered the normalized form before. The array + # 'known' is our cache where we record the known normalized + # paths. + + set pending [list $basedir] + set at 0 + array set parent {} + array set norm {} + Enter {} $basedir + + while {$at < [llength $pending]} { + # Get next directory not yet processed. + set current [lindex $pending $at] + incr at + + # Is the directory accessible? Continue if not. + ACCESS $current + + # Files first, then the sub-directories ... + + foreach f [GLOBF $current] { FADD $f } + + foreach f [GLOBD $current] { + # Ignore current and parent directory, this needs + # explicit filtering outside of the filter command. + if { + [string equal [file tail $f] "."] || + [string equal [file tail $f] ".."] + } continue + + # Extend result, modulo filtering. + FADD $f + + # Detection of symlink loops via a portable path + # normalization computing a canonical form of the path + # followed by a check if that canonical form was + # encountered before. If ok, record directory for + # expansion in future iterations. + + Enter $current $f + if {[Cycle $f]} continue + + lappend pending $f + } + } + } else { + return -code error "$basedir does not exist" + } + + return $result +} + +proc ::fileutil::Enter {parent path} { + upvar 1 parent _parent norm _norm + set _parent($path) $parent + set _norm($path) [fullnormalize $path] + return +} + +proc ::fileutil::Cycle {path} { + upvar 1 parent _parent norm _norm + set nform $_norm($path) + set paren $_parent($path) + while {$paren ne {}} { + if {$_norm($paren) eq $nform} { return yes } + set paren $_parent($paren) + } + return no +} + +# Helper command for fileutil::find. Performs the filtering of the +# result per a filter command for the candidates found by the +# traversal core, see above. This is portable. + +proc ::fileutil::FADD {filename} { + upvar 1 result result filt filt filtercmd filtercmd + if {!$filt} { + lappend result $filename + return + } + + set here [pwd] + cd [file dirname $filename] + + if {[uplevel 2 [linsert $filtercmd end [file tail $filename]]]} { + lappend result $filename + } + + cd $here + return +} + +# The next three helper commands for fileutil::find depend strongly on +# the version of Tcl, and partially on the platform. + +# 1. The -directory and -types switches were added to glob in Tcl +# 8.3. This means that we have to emulate them for Tcl 8.2. +# +# 2. In Tcl 8.3 using -types f will return only true files, but not +# links to files. This changed in 8.4+ where links to files are +# returned as well. So for 8.3 we have to handle the links +# separately (-types l) and also filter on our own. +# Note that Windows file links are hard links which are reported by +# -types f, but not -types l, so we can optimize that for the two +# platforms. +# +# Note further that we have to handle broken links on our own. They +# are not returned by glob yet we want them in the output. +# +# 3. In Tcl 8.3 we also have a crashing bug in glob (SIGABRT, "stat on +# a known file") when trying to perform 'glob -types {hidden f}' on +# a directory without e'x'ecute permissions. We code around by +# testing if we can cd into the directory (stat might return enough +# information too (mode), but possibly also not portable). +# +# For Tcl 8.2 and 8.4+ glob simply delivers an empty result +# (-nocomplain), without crashing. For them this command is defined +# so that the bytecode compiler removes it from the bytecode. +# +# This bug made the ACCESS helper necessary. +# We code around the problem by testing if we can cd into the +# directory (stat might return enough information too (mode), but +# possibly also not portable). + +if {[package vsatisfies [package present Tcl] 8.5]} { + # Tcl 8.5+. + # We have to check readability of "current" on our own, glob + # changed to error out instead of returning nothing. + + proc ::fileutil::ACCESS {args} {} + + proc ::fileutil::GLOBF {current} { + if {![file readable $current] || + [BadLink $current]} { + return {} + } + + set res [lsort -unique [concat \ + [glob -nocomplain -directory $current -types f -- *] \ + [glob -nocomplain -directory $current -types {hidden f} -- *]]] + + # Look for broken links (They are reported as neither file nor directory). + foreach l [lsort -unique [concat \ + [glob -nocomplain -directory $current -types l -- *] \ + [glob -nocomplain -directory $current -types {hidden l} -- *]]] { + if {[file isfile $l]} continue + if {[file isdirectory $l]} continue + lappend res $l + } + return [lsort -unique $res] + } + + proc ::fileutil::GLOBD {current} { + if {![file readable $current] || + [BadLink $current]} { + return {} + } + + lsort -unique [concat \ + [glob -nocomplain -directory $current -types d -- *] \ + [glob -nocomplain -directory $current -types {hidden d} -- *]] + } + + proc ::fileutil::BadLink {current} { + if {[file type $current] ne "link"} { return no } + + set dst [file join [file dirname $current] [file readlink $current]] + + if {![file exists $dst] || + ![file readable $dst]} { + return yes + } + + return no + } +} elseif {[package vsatisfies [package present Tcl] 8.4]} { + # Tcl 8.4+. + # (Ad 1) We have -directory, and -types, + # (Ad 2) Links are returned for -types f/d if they refer to files/dirs. + # (Ad 3) No bug to code around + + proc ::fileutil::ACCESS {args} {} + + proc ::fileutil::GLOBF {current} { + set res [lsort -unique [concat \ + [glob -nocomplain -directory $current -types f -- *] \ + [glob -nocomplain -directory $current -types {hidden f} -- *]]] + + # Look for broken links (They are reported as neither file nor directory). + foreach l [lsort -unique [concat \ + [glob -nocomplain -directory $current -types l -- *] \ + [glob -nocomplain -directory $current -types {hidden l} -- *]]] { + if {[file isfile $l]} continue + if {[file isdirectory $l]} continue + lappend res $l + } + return [lsort -unique $res] + } + + proc ::fileutil::GLOBD {current} { + lsort -unique [concat \ + [glob -nocomplain -directory $current -types d -- *] \ + [glob -nocomplain -directory $current -types {hidden d} -- *]] + } + +} elseif {[package vsatisfies [package present Tcl] 8.3]} { + # 8.3. + # (Ad 1) We have -directory, and -types, + # (Ad 2) Links are NOT returned for -types f/d, collect separately. + # No symbolic file links on Windows. + # (Ad 3) Bug to code around. + + proc ::fileutil::ACCESS {current} { + if {[catch { + set h [pwd] ; cd $current ; cd $h + }]} {return -code continue} + return + } + + if {[string equal $::tcl_platform(platform) windows]} { + proc ::fileutil::GLOBF {current} { + concat \ + [glob -nocomplain -directory $current -types f -- *] \ + [glob -nocomplain -directory $current -types {hidden f} -- *]] + } + } else { + proc ::fileutil::GLOBF {current} { + set l [concat \ + [glob -nocomplain -directory $current -types f -- *] \ + [glob -nocomplain -directory $current -types {hidden f} -- *]] + + foreach x [concat \ + [glob -nocomplain -directory $current -types l -- *] \ + [glob -nocomplain -directory $current -types {hidden l} -- *]] { + if {[file isdirectory $x]} continue + # We have now accepted files, links to files, and broken links. + lappend l $x + } + + return $l + } + } + + proc ::fileutil::GLOBD {current} { + set l [concat \ + [glob -nocomplain -directory $current -types d -- *] \ + [glob -nocomplain -directory $current -types {hidden d} -- *]] + + foreach x [concat \ + [glob -nocomplain -directory $current -types l -- *] \ + [glob -nocomplain -directory $current -types {hidden l} -- *]] { + if {![file isdirectory $x]} continue + lappend l $x + } + + return $l + } +} else { + # 8.2. + # (Ad 1,2,3) We do not have -directory, nor -types. Full emulation required. + + proc ::fileutil::ACCESS {args} {} + + if {[string equal $::tcl_platform(platform) windows]} { + # Hidden files cannot be handled by Tcl 8.2 in glob. We have + # to punt. + + proc ::fileutil::GLOBF {current} { + set current \\[join [split $current {}] \\] + set res {} + foreach x [glob -nocomplain -- [file join $current *]] { + if {[file isdirectory $x]} continue + if {[catch {file type $x}]} continue + # We have now accepted files, links to files, and + # broken links. We may also have accepted a directory + # as well, if the current path was inaccessible. This + # however will cause 'file type' to throw an error, + # hence the second check. + lappend res $x + } + return $res + } + + proc ::fileutil::GLOBD {current} { + set current \\[join [split $current {}] \\] + set res {} + foreach x [glob -nocomplain -- [file join $current *]] { + if {![file isdirectory $x]} continue + lappend res $x + } + return $res + } + } else { + # Hidden files on Unix are dot-files. We emulate the switch + # '-types hidden' by using an explicit pattern. + + proc ::fileutil::GLOBF {current} { + set current \\[join [split $current {}] \\] + set res {} + foreach x [glob -nocomplain -- [file join $current *] [file join $current .*]] { + if {[file isdirectory $x]} continue + if {[catch {file type $x}]} continue + # We have now accepted files, links to files, and + # broken links. We may also have accepted a directory + # as well, if the current path was inaccessible. This + # however will cause 'file type' to throw an error, + # hence the second check. + + lappend res $x + } + return $res + } + + proc ::fileutil::GLOBD {current} { + set current \\[join [split $current {}] \\] + set res {} + foreach x [glob -nocomplain -- $current/* [file join $current .*]] { + if {![file isdirectory $x]} continue + lappend res $x + } + return $res + } + } +} + +# ::fileutil::findByPattern -- +# +# Specialization of find. Finds files based on their names, +# which have to match the specified patterns. Options are used +# to specify which type of patterns (regexp-, glob-style) is +# used. +# +# Arguments: +# basedir Directory to start searching from. +# args Options (-glob, -regexp, --) followed by a +# list of patterns to search for. +# +# Results: +# files a list of interesting files. + +proc ::fileutil::findByPattern {basedir args} { + set pos 0 + set cmd ::fileutil::FindGlob + foreach a $args { + incr pos + switch -glob -- $a { + -- {break} + -regexp {set cmd ::fileutil::FindRegexp} + -glob {set cmd ::fileutil::FindGlob} + -* {return -code error "Unknown option $a"} + default {incr pos -1 ; break} + } + } + + set args [lrange $args $pos end] + + if {[llength $args] != 1} { + set pname [lindex [info level 0] 0] + return -code error \ + "wrong#args for \"$pname\", should be\ + \"$pname basedir ?-regexp|-glob? ?--? patterns\"" + } + + set patterns [lindex $args 0] + return [find $basedir [list $cmd $patterns]] +} + + +# ::fileutil::FindRegexp -- +# +# Internal helper. Filter command used by 'findByPattern' +# to match files based on regular expressions. +# +# Arguments: +# patterns List of regular expressions to match against. +# filename Name of the file to match against the patterns. +# Results: +# interesting A boolean flag. Set to true if the file +# matches at least one of the patterns. + +proc ::fileutil::FindRegexp {patterns filename} { + foreach p $patterns { + if {[regexp -- $p $filename]} { + return 1 + } + } + return 0 +} + +# ::fileutil::FindGlob -- +# +# Internal helper. Filter command used by 'findByPattern' +# to match files based on glob expressions. +# +# Arguments: +# patterns List of glob expressions to match against. +# filename Name of the file to match against the patterns. +# Results: +# interesting A boolean flag. Set to true if the file +# matches at least one of the patterns. + +proc ::fileutil::FindGlob {patterns filename} { + foreach p $patterns { + if {[string match $p $filename]} { + return 1 + } + } + return 0 +} + +# ::fileutil::stripPwd -- +# +# If the specified path references is a path in [pwd] (or [pwd] itself) it +# is made relative to [pwd]. Otherwise it is left unchanged. +# In the case of [pwd] itself the result is the string '.'. +# +# Arguments: +# path path to modify +# +# Results: +# path The (possibly) modified path. + +proc ::fileutil::stripPwd {path} { + + # [file split] is used to generate a canonical form for both + # paths, for easy comparison, and also one which is easy to modify + # using list commands. + + set pwd [pwd] + if {[string equal $pwd $path]} { + return "." + } + + set pwd [file split $pwd] + set npath [file split $path] + + if {[string match ${pwd}* $npath]} { + set path [eval [linsert [lrange $npath [llength $pwd] end] 0 file join ]] + } + return $path +} + +# ::fileutil::stripN -- +# +# Removes N elements from the beginning of the path. +# +# Arguments: +# path path to modify +# n number of elements to strip +# +# Results: +# path The modified path + +proc ::fileutil::stripN {path n} { + set path [file split $path] + if {$n >= [llength $path]} { + return {} + } else { + return [eval [linsert [lrange $path $n end] 0 file join]] + } +} + +# ::fileutil::stripPath -- +# +# If the specified path references/is a path in prefix (or prefix itself) it +# is made relative to prefix. Otherwise it is left unchanged. +# In the case of it being prefix itself the result is the string '.'. +# +# Arguments: +# prefix prefix to strip from the path. +# path path to modify +# +# Results: +# path The (possibly) modified path. + +if {[string equal $tcl_platform(platform) windows]} { + + # Windows. While paths are stored with letter-case preserved al + # comparisons have to be done case-insensitive. For reference see + # SF Tcllib Bug 2499641. + + proc ::fileutil::stripPath {prefix path} { + # [file split] is used to generate a canonical form for both + # paths, for easy comparison, and also one which is easy to modify + # using list commands. + + set prefix [file split $prefix] + set npath [file split $path] + + if {[string equal -nocase $prefix $npath]} { + return "." + } + + if {[string match -nocase "${prefix} *" $npath]} { + set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] + } + return $path + } +} else { + proc ::fileutil::stripPath {prefix path} { + # [file split] is used to generate a canonical form for both + # paths, for easy comparison, and also one which is easy to modify + # using list commands. + + set prefix [file split $prefix] + set npath [file split $path] + + if {[string equal $prefix $npath]} { + return "." + } + + if {[string match "${prefix} *" $npath]} { + set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] + } + return $path + } +} + +# ::fileutil::jail -- +# +# Ensures that the input path 'filename' stays within the +# directory 'jail'. In this way it prevents user-supplied paths +# from escaping the jail. +# +# Arguments: +# jail The path to the directory the other must +# not escape from. +# filename The path to prevent from escaping. +# +# Results: +# path The (possibly) modified path surely within +# the confines of the jail. + +proc fileutil::jail {jail filename} { + if {![string equal [file pathtype $filename] "relative"]} { + # Although the path to check is absolute (or volumerelative on + # windows) we cannot perform a simple prefix check to see if + # the path is inside the jail or not. We have to normalize + # both path and jail and then we can check. If the path is + # outside we make the original path relative and prefix it + # with the original jail. We do make the jail pseudo-absolute + # by prefixing it with the current working directory for that. + + # Normalized jail. Fully resolved sym links, if any. Our main + # complication is that normalize does not resolve symlinks in the + # last component of the path given to it, so we add a bogus + # component, resolve, and then strip it off again. That is why the + # code is so large and long. + + set njail [eval [list file join] [lrange [file split \ + [Normalize [file join $jail __dummy__]]] 0 end-1]] + + # Normalize filename. Fully resolved sym links, if + # any. S.a. for an explanation of the complication. + + set nfile [eval [list file join] [lrange [file split \ + [Normalize [file join $filename __dummy__]]] 0 end-1]] + + if {[string match ${njail}* $nfile]} { + return $filename + } + + # Outside the jail, put it inside. ... We normalize the input + # path lexically for this, to prevent escapes still lurking in + # the original path. (We cannot use the normalized path, + # symlinks may have bent it out of shape in unrecognizable ways. + + return [eval [linsert [lrange [file split \ + [lexnormalize $filename]] 1 end] 0 file join [pwd] $jail]] + } else { + # The path is relative, consider it as outside + # implicitly. Normalize it lexically! to prevent escapes, then + # put the jail in front, use PWD to ensure absoluteness. + + return [eval [linsert [file split [lexnormalize $filename]] 0 \ + file join [pwd] $jail]] + } +} + + +# ::fileutil::test -- +# +# Simple API to testing various properties of +# a path (read, write, file/dir, existence) +# +# Arguments: +# path path to test +# codes names of the properties to test +# msgvar Name of variable to leave an error +# message in. Optional. +# label Label for error message, optional +# +# Results: +# ok boolean flag, set if the path passes +# all tests. + +namespace eval ::fileutil { + variable test + array set test { + read {readable {Read access is denied}} + write {writable {Write access is denied}} + exec {executable {Is not executable}} + exists {exists {Does not exist}} + file {isfile {Is not a file}} + dir {isdirectory {Is not a directory}} + } +} + +proc ::fileutil::test {path codes {msgvar {}} {label {}}} { + variable test + + if {[string equal $msgvar ""]} { + set msg "" + } else { + upvar 1 $msgvar msg + } + + if {![string equal $label ""]} {append label { }} + + if {![regexp {^(read|write|exec|exists|file|dir)} $codes]} { + # Translate single characters into proper codes + set codes [string map { + r read w write e exists x exec f file d dir + } [split $codes {}]] + } + + foreach c $codes { + foreach {cmd text} $test($c) break + if {![file $cmd $path]} { + set msg "$label\"$path\": $text" + return 0 + } + } + + return 1 +} + +# ::fileutil::cat -- +# +# Tcl implementation of the UNIX "cat" command. Returns the contents +# of the specified files. +# +# Arguments: +# args names of the files to read, interspersed with options +# to set encodings, translations, or eofchar. +# +# Results: +# data data read from the file. + +proc ::fileutil::cat {args} { + # Syntax: (?options? file)+ + # options = -encoding ENC + # | -translation TRA + # | -eofchar ECH + # | -- + + if {![llength $args]} { + # Argument processing stopped with arguments missing. + return -code error \ + "wrong#args: should be\ + [lindex [info level 0] 0] ?-eofchar|-translation|-encoding arg?+ file ..." + } + + # We go through the arguments using foreach and keeping track of + # the index we are at. We do not shift the arguments out to the + # left. That is inherently quadratic, copying everything down. + + set opts {} + set mode maybeopt + set channels {} + + foreach a $args { + if {[string equal $mode optarg]} { + lappend opts $a + set mode maybeopt + continue + } elseif {[string equal $mode maybeopt]} { + if {[string match -* $a]} { + switch -exact -- $a { + -encoding - + -translation - + -eofchar { + lappend opts $a + set mode optarg + continue + } + -- { + set mode file + continue + } + default { + return -code error \ + "Bad option \"$a\",\ + expected one of\ + -encoding, -eofchar,\ + or -translation" + } + } + } + # Not an option, but a file. Change mode and fall through. + set mode file + } + # Process file arguments + + if {[string equal $a -]} { + # Stdin reference is special. + + # Test that the current options are all ok. + # For stdin we have to avoid closing it. + + set old [fconfigure stdin] + set fail [catch { + SetOptions stdin $opts + } msg] ; # {} + SetOptions stdin $old + + if {$fail} { + return -code error $msg + } + + lappend channels [list $a $opts 0] + } else { + if {![file exists $a]} { + return -code error "Cannot read file \"$a\", does not exist" + } elseif {![file isfile $a]} { + return -code error "Cannot read file \"$a\", is not a file" + } elseif {![file readable $a]} { + return -code error "Cannot read file \"$a\", read access is denied" + } + + # Test that the current options are all ok. + set c [open $a r] + set fail [catch { + SetOptions $c $opts + } msg] ; # {} + close $c + if {$fail} { + return -code error $msg + } + + lappend channels [list $a $opts [file size $a]] + } + + # We may have more options and files coming after. + set mode maybeopt + } + + if {![string equal $mode maybeopt]} { + # Argument processing stopped with arguments missing. + return -code error \ + "wrong#args: should be\ + [lindex [info level 0] 0] ?-eofchar|-translation|-encoding arg?+ file ..." + } + + set data "" + foreach c $channels { + foreach {fname opts size} $c break + + if {[string equal $fname -]} { + set old [fconfigure stdin] + SetOptions stdin $opts + append data [read stdin] + SetOptions stdin $old + continue + } + + set c [open $fname r] + SetOptions $c $opts + + if {$size > 0} { + # Used the [file size] command to get the size, which + # preallocates memory, rather than trying to grow it as + # the read progresses. + append data [read $c $size] + } else { + # if the file has zero bytes it is either empty, or + # something where [file size] reports 0 but the file + # actually has data (like the files in the /proc + # filesystem on Linux). + append data [read $c] + } + close $c + } + + return $data +} + +# ::fileutil::writeFile -- +# +# Write the specified data into the named file, +# creating it if necessary. +# +# Arguments: +# options... Options and arguments. +# filename Path to the file to write. +# data The data to write into the file +# +# Results: +# None. + +proc ::fileutil::writeFile {args} { + # Syntax: ?options? file data + # options = -encoding ENC + # | -translation TRA + # | -eofchar ECH + # | -- + + Spec Writable $args opts fname data + + # Now perform the requested operation. + + file mkdir [file dirname $fname] + set c [open $fname w] + SetOptions $c $opts + puts -nonewline $c $data + close $c + return +} + +# ::fileutil::appendToFile -- +# +# Append the specified data at the end of the named file, +# creating it if necessary. +# +# Arguments: +# options... Options and arguments. +# filename Path to the file to extend. +# data The data to extend the file with. +# +# Results: +# None. + +proc ::fileutil::appendToFile {args} { + # Syntax: ?options? file data + # options = -encoding ENC + # | -translation TRA + # | -eofchar ECH + # | -- + + Spec Writable $args opts fname data + + # Now perform the requested operation. + + file mkdir [file dirname $fname] + set c [open $fname a] + SetOptions $c $opts + set at [tell $c] + puts -nonewline $c $data + close $c + return $at +} + +# ::fileutil::insertIntoFile -- +# +# Insert the specified data into the named file, +# creating it if necessary, at the given locaton. +# +# Arguments: +# options... Options and arguments. +# filename Path to the file to extend. +# data The data to extend the file with. +# +# Results: +# None. + +proc ::fileutil::insertIntoFile {args} { + + # Syntax: ?options? file at data + # options = -encoding ENC + # | -translation TRA + # | -eofchar ECH + # | -- + + Spec ReadWritable $args opts fname at data + + set max [file size $fname] + CheckLocation $at $max insertion + + if {[string length $data] == 0} { + # Another degenerate case, inserting nothing. + # Leave the file well enough alone. + return + } + + foreach {c o t} [Open2 $fname $opts] break + + # The degenerate cases of both appending and insertion at the + # beginning of the file allow more optimized implementations of + # the operation. + + if {$at == 0} { + puts -nonewline $o $data + fcopy $c $o + } elseif {$at == $max} { + fcopy $c $o + puts -nonewline $o $data + } else { + fcopy $c $o -size $at + puts -nonewline $o $data + fcopy $c $o + } + + Close2 $fname $t $c $o + return +} + +# ::fileutil::removeFromFile -- +# +# Remove n characters from the named file, +# starting at the given locaton. +# +# Arguments: +# options... Options and arguments. +# filename Path to the file to extend. +# at Location to start the removal from. +# n Number of characters to remove. +# +# Results: +# None. + +proc ::fileutil::removeFromFile {args} { + + # Syntax: ?options? file at n + # options = -encoding ENC + # | -translation TRA + # | -eofchar ECH + # | -- + + Spec ReadWritable $args opts fname at n + + set max [file size $fname] + CheckLocation $at $max removal + CheckLength $n $at $max removal + + if {$n == 0} { + # Another degenerate case, removing nothing. + # Leave the file well enough alone. + return + } + + foreach {c o t} [Open2 $fname $opts] break + + # The degenerate cases of both removal from the beginning or end + # of the file allow more optimized implementations of the + # operation. + + if {$at == 0} { + seek $c $n current + fcopy $c $o + } elseif {($at + $n) == $max} { + fcopy $c $o -size $at + # Nothing further to copy. + } else { + fcopy $c $o -size $at + seek $c $n current + fcopy $c $o + } + + Close2 $fname $t $c $o + return +} + +# ::fileutil::replaceInFile -- +# +# Remove n characters from the named file, +# starting at the given locaton, and replace +# it with the given data. +# +# Arguments: +# options... Options and arguments. +# filename Path to the file to extend. +# at Location to start the removal from. +# n Number of characters to remove. +# data The replacement data. +# +# Results: +# None. + +proc ::fileutil::replaceInFile {args} { + + # Syntax: ?options? file at n data + # options = -encoding ENC + # | -translation TRA + # | -eofchar ECH + # | -- + + Spec ReadWritable $args opts fname at n data + + set max [file size $fname] + CheckLocation $at $max replacement + CheckLength $n $at $max replacement + + if { + ($n == 0) && + ([string length $data] == 0) + } { + # Another degenerate case, replacing nothing with + # nothing. Leave the file well enough alone. + return + } + + foreach {c o t} [Open2 $fname $opts] break + + # Check for degenerate cases and handle them separately, + # i.e. strip the no-op parts out of the general implementation. + + if {$at == 0} { + if {$n == 0} { + # Insertion instead of replacement. + + puts -nonewline $o $data + fcopy $c $o + + } elseif {[string length $data] == 0} { + # Removal instead of replacement. + + seek $c $n current + fcopy $c $o + + } else { + # General replacement at front. + + seek $c $n current + puts -nonewline $o $data + fcopy $c $o + } + } elseif {($at + $n) == $max} { + if {$n == 0} { + # Appending instead of replacement + + fcopy $c $o + puts -nonewline $o $data + + } elseif {[string length $data] == 0} { + # Truncating instead of replacement + + fcopy $c $o -size $at + # Nothing further to copy. + + } else { + # General replacement at end + + fcopy $c $o -size $at + puts -nonewline $o $data + } + } else { + if {$n == 0} { + # General insertion. + + fcopy $c $o -size $at + puts -nonewline $o $data + fcopy $c $o + + } elseif {[string length $data] == 0} { + # General removal. + + fcopy $c $o -size $at + seek $c $n current + fcopy $c $o + + } else { + # General replacement. + + fcopy $c $o -size $at + seek $c $n current + puts -nonewline $o $data + fcopy $c $o + } + } + + Close2 $fname $t $c $o + return +} + +# ::fileutil::updateInPlace -- +# +# Run command prefix on the contents of the +# file and replace them with the result of +# the command. +# +# Arguments: +# options... Options and arguments. +# filename Path to the file to extend. +# cmd Command prefix to run. +# +# Results: +# None. + +proc ::fileutil::updateInPlace {args} { + # Syntax: ?options? file cmd + # options = -encoding ENC + # | -translation TRA + # | -eofchar ECH + # | -- + + Spec ReadWritable $args opts fname cmd + + # readFile/cat inlined ... + + set c [open $fname r] + SetOptions $c $opts + set data [read $c] + close $c + + # Transformation. Abort and do not modify the target file if an + # error was raised during this step. + + lappend cmd $data + set code [catch {uplevel 1 $cmd} res] + if {$code} { + return -code $code $res + } + + # writeFile inlined, with careful preservation of old contents + # until we are sure that the write was ok. + + if {[catch { + file rename -force $fname ${fname}.bak + + set o [open $fname w] + SetOptions $o $opts + puts -nonewline $o $res + close $o + + file delete -force ${fname}.bak + } msg]} { + if {[file exists ${fname}.bak]} { + catch { + file rename -force ${fname}.bak $fname + } + return -code error $msg + } + } + return +} + +proc ::fileutil::Writable {fname mv} { + upvar 1 $mv msg + if {[file exists $fname]} { + if {![file isfile $fname]} { + set msg "Cannot use file \"$fname\", is not a file" + return 0 + } elseif {![file writable $fname]} { + set msg "Cannot use file \"$fname\", write access is denied" + return 0 + } + } + return 1 +} + +proc ::fileutil::ReadWritable {fname mv} { + upvar 1 $mv msg + if {![file exists $fname]} { + set msg "Cannot use file \"$fname\", does not exist" + return 0 + } elseif {![file isfile $fname]} { + set msg "Cannot use file \"$fname\", is not a file" + return 0 + } elseif {![file writable $fname]} { + set msg "Cannot use file \"$fname\", write access is denied" + return 0 + } elseif {![file readable $fname]} { + set msg "Cannot use file \"$fname\", read access is denied" + return 0 + } + return 1 +} + +proc ::fileutil::Spec {check alist ov fv args} { + upvar 1 $ov opts $fv fname + + set n [llength $args] ; # Num more args + incr n ; # Count path as well + + set opts {} + set mode maybeopt + + set at 0 + foreach a $alist { + if {[string equal $mode optarg]} { + lappend opts $a + set mode maybeopt + incr at + continue + } elseif {[string equal $mode maybeopt]} { + if {[string match -* $a]} { + switch -exact -- $a { + -encoding - + -translation - + -eofchar { + lappend opts $a + set mode optarg + incr at + continue + } + -- { + # Stop processing. + incr at + break + } + default { + return -code error \ + "Bad option \"$a\",\ + expected one of\ + -encoding, -eofchar,\ + or -translation" + } + } + } + # Not an option, but a file. + # Stop processing. + break + } + } + + if {([llength $alist] - $at) != $n} { + # Argument processing stopped with arguments missing, or too + # many + return -code error \ + "wrong#args: should be\ + [lindex [info level 1] 0] ?-eofchar|-translation|-encoding arg? file $args" + } + + set fname [lindex $alist $at] + incr at + foreach \ + var $args \ + val [lrange $alist $at end] { + upvar 1 $var A + set A $val + } + + # Check given path ... + + if {![eval [linsert $check end $a msg]]} { + return -code error $msg + } + + return +} + +proc ::fileutil::Open2 {fname opts} { + set c [open $fname r] + set t [tempfile] + set o [open $t w] + + SetOptions $c $opts + SetOptions $o $opts + + return [list $c $o $t] +} + +proc ::fileutil::Close2 {f temp in out} { + close $in + close $out + + file copy -force $f ${f}.bak + file rename -force $temp $f + file delete -force ${f}.bak + return +} + +proc ::fileutil::SetOptions {c opts} { + if {![llength $opts]} return + eval [linsert $opts 0 fconfigure $c] + return +} + +proc ::fileutil::CheckLocation {at max label} { + if {![string is integer -strict $at]} { + return -code error \ + "Expected integer but got \"$at\"" + } elseif {$at < 0} { + return -code error \ + "Bad $label point $at, before start of data" + } elseif {$at > $max} { + return -code error \ + "Bad $label point $at, behind end of data" + } +} + +proc ::fileutil::CheckLength {n at max label} { + if {![string is integer -strict $n]} { + return -code error \ + "Expected integer but got \"$n\"" + } elseif {$n < 0} { + return -code error \ + "Bad $label size $n" + } elseif {($at + $n) > $max} { + return -code error \ + "Bad $label size $n, going behind end of data" + } +} + +# ::fileutil::foreachLine -- +# +# Executes a script for every line in a file. +# +# Arguments: +# var name of the variable to contain the lines +# filename name of the file to read. +# cmd The script to execute. +# +# Results: +# None. + +proc ::fileutil::foreachLine {var filename cmd} { + upvar 1 $var line + set fp [open $filename r] + + # -future- Use try/eval from tcllib/control + catch { + set code 0 + set result {} + set return 0 + while {[gets $fp line] >= 0} { + set code [catch {uplevel 1 $cmd} result options] + if {$code == 2} { + set return 1 + set code [dict get $options -code] + break + } elseif {$code != 0 && $code != 4} { + break + } + } + } + close $fp + + if {$return || $code == 1 || $code > 4} { + return -options $options $result + } + return $result +} + +# ::fileutil::touch -- +# +# Tcl implementation of the UNIX "touch" command. +# +# touch [-a] [-m] [-c] [-r ref_file] [-t time] filename ... +# +# Arguments: +# -a change the access time only, unless -m also specified +# -m change the modification time only, unless -a also specified +# -c silently prevent creating a file if it did not previously exist +# -r ref_file use the ref_file's time instead of the current time +# -t time use the specified time instead of the current time +# ("time" is an integer clock value, like [clock seconds]) +# filename ... the files to modify +# +# Results +# None. +# +# Errors: +# Both of "-r" and "-t" cannot be specified. + +if {[package vsatisfies [package provide Tcl] 8.3]} { + namespace eval ::fileutil { + namespace export touch + } + + proc ::fileutil::touch {args} { + # Don't bother catching errors, just let them propagate up + + set options { + {a "set the atime only"} + {m "set the mtime only"} + {c "do not create non-existant files"} + {r.arg "" "use time from ref_file"} + {t.arg -1 "use specified time"} + } + set usage ": [lindex [info level 0] 0]\ + \[options] filename ...\noptions:" + array set params [::cmdline::getoptions args $options $usage] + + # process -a and -m options + set set_atime [set set_mtime "true"] + if { $params(a) && ! $params(m)} {set set_mtime "false"} + if {! $params(a) && $params(m)} {set set_atime "false"} + + # process -r and -t + set has_t [expr {$params(t) != -1}] + set has_r [expr {[string length $params(r)] > 0}] + if {$has_t && $has_r} { + return -code error "Cannot specify both -r and -t" + } elseif {$has_t} { + set atime [set mtime $params(t)] + } elseif {$has_r} { + file stat $params(r) stat + set atime $stat(atime) + set mtime $stat(mtime) + } else { + set atime [set mtime [clock seconds]] + } + + # do it + foreach filename $args { + if {! [file exists $filename]} { + if {$params(c)} {continue} + close [open $filename w] + } + if {$set_atime} {file atime $filename $atime} + if {$set_mtime} {file mtime $filename $mtime} + } + return + } +} + +# ::fileutil::fileType -- +# +# Do some simple heuristics to determine file type. +# +# +# Arguments: +# filename Name of the file to test. +# +# Results +# type Type of the file. May be a list if multiple tests +# are positive (eg, a file could be both a directory +# and a link). In general, the list proceeds from most +# general (eg, binary) to most specific (eg, gif), so +# the full type for a GIF file would be +# "binary graphic gif" +# +# At present, the following types can be detected: +# +# directory +# empty +# binary +# text +# script +# executable [elf, dos, ne, pe] +# binary graphic [gif, jpeg, png, tiff, bitmap, icns] +# ps, eps, pdf +# html +# xml +# message pgp +# compressed [bzip, gzip, zip, tar] +# audio [mpeg, wave] +# gravity_wave_data_frame +# link +# doctools, doctoc, and docidx documentation files. +# + +proc ::fileutil::fileType {filename} { + ;## existence test + if { ! [ file exists $filename ] } { + set err "file not found: '$filename'" + return -code error $err + } + ;## directory test + if { [ file isdirectory $filename ] } { + set type directory + if { ! [ catch {file readlink $filename} ] } { + lappend type link + } + return $type + } + ;## empty file test + if { ! [ file size $filename ] } { + set type empty + if { ! [ catch {file readlink $filename} ] } { + lappend type link + } + return $type + } + set bin_rx {[\x00-\x08\x0b\x0e-\x1f]} + + if { [ catch { + set fid [ open $filename r ] + fconfigure $fid -translation binary + fconfigure $fid -buffersize 1024 + fconfigure $fid -buffering full + set test [ read $fid 1024 ] + ::close $fid + } err ] } { + catch { ::close $fid } + return -code error "::fileutil::fileType: $err" + } + + if { [ regexp $bin_rx $test ] } { + set type binary + set binary 1 + } else { + set type text + set binary 0 + } + + # SF Tcllib bug [795585]. Allowing whitespace between #! + # and path of script interpreter + + set metakit 0 + + if { [ regexp {^\#\!\s*(\S+)} $test -> terp ] } { + lappend type script $terp + } elseif {([regexp "\\\[manpage_begin " $test] && + !([regexp -- {--- !doctools ---} $test] || [regexp -- "!tcl\.tk//DSL doctools//EN//" $test])) || + ([regexp -- {--- doctools ---} $test] || [regexp -- "tcl\.tk//DSL doctools//EN//" $test])} { + lappend type doctools + } elseif {([regexp "\\\[toc_begin " $test] && + !([regexp -- {--- !doctoc ---} $test] || [regexp -- "!tcl\.tk//DSL doctoc//EN//" $test])) || + ([regexp -- {--- doctoc ---} $test] || [regexp -- "tcl\.tk//DSL doctoc//EN//" $test])} { + lappend type doctoc + } elseif {([regexp "\\\[index_begin " $test] && + !([regexp -- {--- !docidx ---} $test] || [regexp -- "!tcl\.tk//DSL docidx//EN//" $test])) || + ([regexp -- {--- docidx ---} $test] || [regexp -- "tcl\.tk//DSL docidx//EN//" $test])} { + lappend type docidx + } elseif {[regexp -- "tcl\\.tk//DSL diagram//EN//" $test]} { + lappend type tkdiagram + } elseif { $binary && [ regexp {^[\x7F]ELF} $test ] } { + lappend type executable elf + } elseif { $binary && [string match "MZ*" $test] } { + if { [scan [string index $test 24] %c] < 64 } { + lappend type executable dos + } else { + binary scan [string range $test 60 61] s next + set sig [string range $test $next [expr {$next + 1}]] + if { $sig == "NE" || $sig == "PE" } { + lappend type executable [string tolower $sig] + } else { + lappend type executable dos + } + } + } elseif { $binary && [string match "SQLite format 3\x00*" $test] } { + lappend type sqlite3 + + # Check for various sqlite-based application file formats. + set appid [string range $test 68 71] + if {$appid eq "\x0f\x05\x51\x12"} { + lappend type fossil-checkout + } elseif {$appid eq "\x0f\x05\x51\x13"} { + lappend type fossil-global-config + } elseif {$appid eq "\x0f\x05\x51\x11"} { + lappend type fossil-repository + } else { + # encode the appid as hex and append that. + binary scan $appid H8 aid + lappend type A$aid + } + + } elseif { $binary && [string match "BZh91AY\&SY*" $test] } { + lappend type compressed bzip + } elseif { $binary && [string match "\x1f\x8b*" $test] } { + lappend type compressed gzip + } elseif { $binary && [string range $test 257 262] == "ustar\x00" } { + lappend type compressed tar + } elseif { $binary && [string match "\x50\x4b\x03\x04*" $test] } { + lappend type compressed zip + } elseif { $binary && [string match "GIF*" $test] } { + lappend type graphic gif + } elseif { $binary && [string match "icns*" $test] } { + lappend type graphic icns bigendian + } elseif { $binary && [string match "snci*" $test] } { + lappend type graphic icns smallendian + } elseif { $binary && [string match "\x89PNG*" $test] } { + lappend type graphic png + } elseif { $binary && [string match "\xFF\xD8\xFF*" $test] } { + binary scan $test x3H2x2a5 marker txt + if { $marker == "e0" && $txt == "JFIF\x00" } { + lappend type graphic jpeg jfif + } elseif { $marker == "e1" && $txt == "Exif\x00" } { + lappend type graphic jpeg exif + } + } elseif { $binary && [string match "MM\x00\**" $test] } { + lappend type graphic tiff + } elseif { $binary && [string match "BM*" $test] && [string range $test 6 9] == "\x00\x00\x00\x00" } { + lappend type graphic bitmap + } elseif { ! $binary && [string match -nocase "*\*" $test] } { + lappend type html + } elseif {[string match "\%PDF\-*" $test] } { + lappend type pdf + } elseif { [string match "\%\!PS\-*" $test] } { + lappend type ps + if { [string match "* EPSF\-*" $test] } { + lappend type eps + } + } elseif { [string match -nocase "*\<\?xml*" $test] } { + lappend type xml + if { [ regexp -nocase {\<\!DOCTYPE\s+(\S+)} $test -> doctype ] } { + lappend type $doctype + } + } elseif { [string match {*BEGIN PGP MESSAGE*} $test] } { + lappend type message pgp + } elseif { $binary && [string match {IGWD*} $test] } { + lappend type gravity_wave_data_frame + } elseif {[string match "JL\x1a\x00*" $test] && ([file size $filename] >= 27)} { + lappend type metakit smallendian + set metakit 1 + } elseif {[string match "LJ\x1a\x00*" $test] && ([file size $filename] >= 27)} { + lappend type metakit bigendian + set metakit 1 + } elseif { $binary && [string match "RIFF*" $test] && [string range $test 8 11] == "WAVE" } { + lappend type audio wave + } elseif { $binary && [string match "ID3*" $test] } { + lappend type audio mpeg + } elseif { $binary && [binary scan $test S tmp] && [expr {$tmp & 0xFFE0}] == 65504 } { + lappend type audio mpeg + } + + # Additional checks of file contents at the end of the file, + # possibly pointing into the middle too (attached metakit, + # attached zip). + + ## Metakit File format: http://www.equi4.com/metakit/metakit-ff.html + ## Metakit database attached ? ## + + if {!$metakit && ([file size $filename] >= 27)} { + # The offsets in the footer are in always bigendian format + + if { [ catch { + set fid [ open $filename r ] + fconfigure $fid -translation binary + fconfigure $fid -buffersize 1024 + fconfigure $fid -buffering full + seek $fid -16 end + set test [ read $fid 16 ] + ::close $fid + } err ] } { + catch { ::close $fid } + return -code error "::fileutil::fileType: $err" + } + + binary scan $test IIII __ hdroffset __ __ + set hdroffset [expr {[file size $filename] - 16 - $hdroffset}] + + # Further checks iff the offset is actually inside the file. + + if {($hdroffset >= 0) && ($hdroffset < [file size $filename])} { + # Seek to the specified location and try to match a metakit header + # at this location. + + if { [ catch { + set fid [ open $filename r ] + fconfigure $fid -translation binary + fconfigure $fid -buffersize 1024 + fconfigure $fid -buffering full + seek $fid $hdroffset start + set test [ read $fid 16 ] + ::close $fid + } err ] } { + catch { ::close $fid } + return -code error "::fileutil::fileType: $err" + } + + if {[string match "JL\x1a\x00*" $test]} { + lappend type attached metakit smallendian + set metakit 1 + } elseif {[string match "LJ\x1a\x00*" $test]} { + lappend type attached metakit bigendian + set metakit 1 + } + } + } + + ## Zip File Format: http://zziplib.sourceforge.net/zzip-parse.html + ## http://www.pkware.com/products/enterprise/white_papers/appnote.html + + + ;## lastly, is it a link? + if { ! [ catch {file readlink $filename} ] } { + lappend type link + } + return $type +} + +# ::fileutil::tempdir -- +# +# Return the correct directory to use for temporary files. +# Python attempts this sequence, which seems logical: +# +# 1. The directory named by the `TMPDIR' environment variable. +# +# 2. The directory named by the `TEMP' environment variable. +# +# 3. The directory named by the `TMP' environment variable. +# +# 4. A platform-specific location: +# * On Macintosh, the `Temporary Items' folder. +# +# * On Windows, the directories `C:\\TEMP', `C:\\TMP', +# `\\TEMP', and `\\TMP', in that order. +# +# * On all other platforms, the directories `/tmp', +# `/var/tmp', and `/usr/tmp', in that order. +# +# 5. As a last resort, the current working directory. +# +# The code here also does +# +# 0. The directory set by invoking tempdir with an argument. +# If this is present it is used exclusively. +# +# Arguments: +# None. +# +# Side Effects: +# None. +# +# Results: +# The directory for temporary files. + +proc ::fileutil::tempdir {args} { + if {[llength $args] > 1} { + return -code error {wrong#args: should be "::fileutil::tempdir ?path?"} + } elseif {[llength $args] == 1} { + variable tempdir [lindex $args 0] + variable tempdirSet 1 + return + } + return [Normalize [TempDir]] +} + +proc ::fileutil::tempdirReset {} { + variable tempdir {} + variable tempdirSet 0 + return +} + +proc ::fileutil::TempDir {} { + global tcl_platform env + variable tempdir + variable tempdirSet + + set attempdirs [list] + set problems {} + + if {$tempdirSet} { + lappend attempdirs $tempdir + lappend problems {User/Application specified tempdir} + } else { + foreach tmp {TMPDIR TEMP TMP} { + if { [info exists env($tmp)] } { + lappend attempdirs $env($tmp) + } else { + lappend problems "No environment variable $tmp" + } + } + + switch $tcl_platform(platform) { + windows { + lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP" + } + macintosh { + lappend attempdirs $env(TRASH_FOLDER) ;# a better place? + } + default { + lappend attempdirs \ + [file join / tmp] \ + [file join / var tmp] \ + [file join / usr tmp] + } + } + + lappend attempdirs [pwd] + } + + foreach tmp $attempdirs { + if { [file isdirectory $tmp] && [file writable $tmp] } { + return $tmp + } elseif { ![file isdirectory $tmp] } { + lappend problems "Not a directory: $tmp" + } else { + lappend problems "Not writable: $tmp" + } + } + + # Fail if nothing worked. + return -code error "Unable to determine a proper directory for temporary files\n[join $problems \n]" +} + +namespace eval ::fileutil { + variable tempdir {} + variable tempdirSet 0 +} + +# ::fileutil::maketempdir -- + +proc ::fileutil::maketempdir {args} { + return [Normalize [MakeTempDir $args]] +} + +proc ::fileutil::MakeTempDir {config} { + # Setup of default configuration. + array set options {} + set options(-suffix) "" + set options(-prefix) "tmp" + set options(-dir) [tempdir] + + # TODO: Check for and reject options not in -suffix, -prefix, -dir + # Merge user configuration, overwrite defaults. + array set options $config + + # See also "tempfile" below. Could be shareable internal configuration. + set chars abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789 + set nrand_chars 10 + set maxtries 10 + + for {set i 0} {$i < $maxtries} {incr i} { + # Build up the candidate name. See also "tempfile". + set directory_name $options(-prefix) + for {set j 0} {$j < $nrand_chars} {incr j} { + append directory_name \ + [string index $chars [expr {int(rand() * 62)}]] + } + append directory_name $options(-suffix) + set path [file join $options(-dir) $directory_name] + + # Try to create. Try again if already exists, or trouble + # with creation and setting of perms. + # + # Note: The last looks as if it is able to leave partial + # directories behind (created, trouble with perms). But + # deleting ... Might pull the rug out from somebody else. + + if {[file exists $path]} continue + if {[catch { + file mkdir $path + if {$::tcl_platform(platform) eq "unix"} { + file attributes $path -permissions 0700 + } + }]} continue + + return $path + } + return -code error "Failed to find an unused temporary directory name" +} + +# ::fileutil::tempfile -- +# +# generate a temporary file name suitable for writing to +# the file name will be unique, writable and will be in the +# appropriate system specific temp directory +# Code taken from http://mini.net/tcl/772 attributed to +# Igor Volobouev and anon. +# +# Arguments: +# prefix - a prefix for the filename, p +# Results: +# returns a file name +# + +proc ::fileutil::tempfile {{prefix {}}} { + return [Normalize [TempFile $prefix]] +} + +proc ::fileutil::TempFile {prefix} { + set tmpdir [tempdir] + + set chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" + set nrand_chars 10 + set maxtries 10 + set access [list RDWR CREAT EXCL] + set permission 0600 + set channel "" + set checked_dir_writable 0 + + for {set i 0} {$i < $maxtries} {incr i} { + set newname $prefix + for {set j 0} {$j < $nrand_chars} {incr j} { + append newname [string index $chars \ + [expr {int(rand()*62)}]] + } + set newname [file join $tmpdir $newname] + + if {[catch {open $newname $access $permission} channel]} { + if {!$checked_dir_writable} { + set dirname [file dirname $newname] + if {![file writable $dirname]} { + return -code error "Directory $dirname is not writable" + } + set checked_dir_writable 1 + } + } else { + # Success + close $channel + return $newname + } + + } + if {[string compare $channel ""]} { + return -code error "Failed to open a temporary file: $channel" + } else { + return -code error "Failed to find an unused temporary file name" + } +} + +# ::fileutil::install -- +# +# Tcl version of the 'install' command, which copies files from +# one places to another and also optionally sets some attributes +# such as group, owner, and permissions. +# +# Arguments: +# -m Change the file permissions to the specified +# value. Valid arguments are those accepted by +# file attributes -permissions +# +# Results: +# None. + +# TODO - add options for group/owner manipulation. + +proc ::fileutil::install {args} { + set options { + {m.arg "" "Set permission mode"} + } + set usage ": [lindex [info level 0] 0]\ +\[options] source destination \noptions:" + array set params [::cmdline::getoptions args $options $usage] + # Args should now just be the source and destination. + if { [llength $args] < 2 } { + return -code error $usage + } + set src [lindex $args 0] + set dst [lindex $args 1] + file copy -force $src $dst + if { $params(m) != "" } { + set targets [::fileutil::find $dst] + foreach fl $targets { + file attributes $fl -permissions $params(m) + } + } +} + +# ### ### ### ######### ######### ######### + +proc ::fileutil::lexnormalize {sp} { + set spx [file split $sp] + + # Resolution of embedded relative modifiers (., and ..). + + if { + ([lsearch -exact $spx . ] < 0) && + ([lsearch -exact $spx ..] < 0) + } { + # Quick path out if there are no relative modifiers + return $sp + } + + set absolute [expr {![string equal [file pathtype $sp] relative]}] + # A volumerelative path counts as absolute for our purposes. + + set sp $spx + set np {} + set noskip 1 + + while {[llength $sp]} { + set ele [lindex $sp 0] + set sp [lrange $sp 1 end] + set islast [expr {[llength $sp] == 0}] + + if {[string equal $ele ".."]} { + if { + ($absolute && ([llength $np] > 1)) || + (!$absolute && ([llength $np] >= 1)) + } { + # .. : Remove the previous element added to the + # new path, if there actually is enough to remove. + set np [lrange $np 0 end-1] + } + } elseif {[string equal $ele "."]} { + # Ignore .'s, they stay at the current location + continue + } else { + # A regular element. + lappend np $ele + } + } + if {[llength $np] > 0} { + return [eval [linsert $np 0 file join]] + # 8.5: return [file join {*}$np] + } + return {} +} + +# ### ### ### ######### ######### ######### +## Forward compatibility. Some routines require path normalization, +## something we have supported by the builtin 'file' only since Tcl +## 8.4. For versions of Tcl before that, to be supported by the +## module, we implement a normalizer in Tcl itself. Slow, but working. + +if {[package vcompare [package provide Tcl] 8.4] < 0} { + # Pre 8.4. We do not have 'file normalize'. We create an + # approximation for it based on earlier commands. + + # ... Hm. This is lexical normalization. It does not resolve + # symlinks in the path to their origin. + + proc ::fileutil::Normalize {sp} { + set sp [file split $sp] + + # Conversion of the incoming path to absolute. + if {[string equal [file pathtype [lindex $sp 0]] "relative"]} { + set sp [file split [eval [list file join [pwd]] $sp]] + } + + # Resolution of symlink components, and embedded relative + # modifiers (., and ..). + + set np {} + set noskip 1 + while {[llength $sp]} { + set ele [lindex $sp 0] + set sp [lrange $sp 1 end] + set islast [expr {[llength $sp] == 0}] + + if {[string equal $ele ".."]} { + if {[llength $np] > 1} { + # .. : Remove the previous element added to the + # new path, if there actually is enough to remove. + set np [lrange $np 0 end-1] + } + } elseif {[string equal $ele "."]} { + # Ignore .'s, they stay at the current location + continue + } else { + # A regular element. If it is not the last component + # then check if the combination is a symlink, and if + # yes, resolve it. + + lappend np $ele + + if {!$islast && $noskip} { + # The flag 'noskip' is technically not required, + # just 'file exists'. However if a path P does not + # exist, then all longer paths starting with P can + # not exist either, and using the flag to store + # this knowledge then saves us a number of + # unnecessary stat calls. IOW this a performance + # optimization. + + set p [eval file join $np] + set noskip [file exists $p] + if {$noskip} { + if {[string equal link [file type $p]]} { + set dst [file readlink $p] + + # We always push the destination in front of + # the source path (in expanded form). So that + # we handle .., .'s, and symlinks inside of + # this path as well. An absolute path clears + # the result, a relative one just removes the + # last, now resolved component. + + set sp [eval [linsert [file split $dst] 0 linsert $sp 0]] + + if {![string equal relative [file pathtype $dst]]} { + # Absolute|volrelative destination, clear + # result, we have to start over. + set np {} + } else { + # Relative link, just remove the resolved + # component again. + set np [lrange $np 0 end-1] + } + } + } + } + } + } + if {[llength $np] > 0} { + return [eval file join $np] + } + return {} + } +} else { + proc ::fileutil::Normalize {sp} { + file normalize $sp + } +} + +# ::fileutil::relative -- +# +# Taking two _directory_ paths, a base and a destination, computes the path +# of the destination relative to the base. +# +# Arguments: +# base The path to make the destination relative to. +# dst The destination path +# +# Results: +# The path of the destination, relative to the base. + +proc ::fileutil::relative {base dst} { + # Ensure that the link to directory 'dst' is properly done relative to + # the directory 'base'. + + if {![string equal [file pathtype $base] [file pathtype $dst]]} { + return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)" + } + + set base [lexnormalize [file join [pwd] $base]] + set dst [lexnormalize [file join [pwd] $dst]] + + set save $dst + set base [file split $base] + set dst [file split $dst] + + while {[string equal [lindex $dst 0] [lindex $base 0]]} { + set dst [lrange $dst 1 end] + set base [lrange $base 1 end] + if {![llength $dst]} {break} + } + + set dstlen [llength $dst] + set baselen [llength $base] + + if {($dstlen == 0) && ($baselen == 0)} { + # Cases: + # (a) base == dst + + set dst . + } else { + # Cases: + # (b) base is: base/sub = sub + # dst is: base = {} + + # (c) base is: base = {} + # dst is: base/sub = sub + + while {$baselen > 0} { + set dst [linsert $dst 0 ..] + incr baselen -1 + } + # 8.5: set dst [file join {*}$dst] + set dst [eval [linsert $dst 0 file join]] + } + + return $dst +} + +# ::fileutil::relativeUrl -- +# +# Taking two _file_ paths, a base and a destination, computes the path +# of the destination relative to the base, from the inside of the base. +# +# This is how a browser resolves relative links in a file, hence the +# url in the command name. +# +# Arguments: +# base The file path to make the destination relative to. +# dst The destination file path +# +# Results: +# The path of the destination file, relative to the base file. + +proc ::fileutil::relativeUrl {base dst} { + # Like 'relative', but for links from _inside_ a file to a + # different file. + + if {![string equal [file pathtype $base] [file pathtype $dst]]} { + return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)" + } + + set base [lexnormalize [file join [pwd] $base]] + set dst [lexnormalize [file join [pwd] $dst]] + + set basedir [file dirname $base] + set dstdir [file dirname $dst] + + set dstdir [relative $basedir $dstdir] + + # dstdir == '.' on input => dstdir output has trailing './'. Strip + # this superfluous segment off. + + if {[string equal $dstdir "."]} { + return [file tail $dst] + } elseif {[string equal [file tail $dstdir] "."]} { + return [file join [file dirname $dstdir] [file tail $dst]] + } else { + return [file join $dstdir [file tail $dst]] + } +} + +# ::fileutil::fullnormalize -- +# +# Normalizes a path completely. I.e. a symlink in the last +# element is resolved as well, not only symlinks in the higher +# elements. +# +# Arguments: +# path The path to normalize +# +# Results: +# The input path with all symlinks resolved. + +proc ::fileutil::fullnormalize {path} { + # When encountering symlinks in a file copy operation Tcl copies + # the link, not the contents of the file it references. There are + # situations there this is not acceptable. For these this command + # resolves all symbolic links in the path, including in the last + # element of the path. A "file copy" using the return value of + # this command copies an actual file, it will not encounter + # symlinks. + + # BUG / WORKAROUND. Using the / instead of the join seems to work + # around a bug in the path handling on windows which can break the + # core 'file normalize' for symbolic links. This was exposed by + # the find testsuite which could not reproduced outside. I believe + # that there is some deep path bug in the core triggered under + # special circumstances. Use of / likely forces a refresh through + # the string rep and so avoids the problem with the path intrep. + + return [file dirname [Normalize $path/__dummy__]] + #return [file dirname [Normalize [file join $path __dummy__]]] +} diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/natsort-0.1.1.5.tm b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/natsort-0.1.1.5.tm new file mode 100644 index 00000000..0dcf57e7 --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/natsort-0.1.1.5.tm @@ -0,0 +1,1886 @@ +#! /usr/bin/env tclsh + + +package require flagfilter +namespace import ::flagfilter::check_flags + +namespace eval natsort { + proc scriptdir {} { + set possibly_linked_script [file dirname [file normalize [file join [info script] ...]]] + if {[file isdirectory $possibly_linked_script]} { + return $possibly_linked_script + } else { + return [file dirname $possibly_linked_script] + } + } + tcl::tm::add [scriptdir] +} + + +namespace eval natsort { + variable stacktrace_on 0 + + proc do_error {msg {then error}} { + #note we exit or error out even if debug selected - as every do_error call is meant to interrupt code processing at the site of call + #this is not just a 'logging' call even though it has log-like descriptors + lassign $then type code + if {$code eq ""} { + set code 1 + } + set type [string tolower $type] + set levels [list debug info notice warn error critical] + if {$type in [concat $levels exit]} { + puts stderr "|$type> $msg" + } else { + puts stderr "|>natsort_call_err> unable to interpret 2nd argument to do_error: '$then' should be one of '$levels' or 'exit '" + } + if {$::tcl_interactive} { + #may not always be desirable - but assumed to be more useful not to exit despite request, to aid in debugging + if {[string tolower $type] eq "exit"} { + puts stderr " (exit suppressed due to tcl_interactive - raising error instead)" + if {![string is digit -strict $code]} { + puts stderr "|>natsort_call_err> unable to interpret 2nd argument to do_error: '$then' should be: 'exit '" + } + } + return -code error $msg + } else { + if {$type ne "exit"} { + return -code error $msg + } else { + if {[string is digit -strict $code]} { + exit $code + } else { + puts stderr "|>natsort_call_err> unable to interpret 2nd argument to do_error: '$then' should be 'error' or 'exit '" + return -code error $msg + } + } + } + } + + + + + + + variable debug 0 + variable testlist + set testlist { + 00.test-firstposition.txt + 0001.blah.txt + 1.test-sorts-after-all-leadingzero-number-one-equivs.txt + 1010.thousand-and-ten.second.txt + 01010.thousand-and-ten.first.txt + 0001.aaa.txt + 001.zzz.txt + 08.octal.txt-last-octal + 008.another-octal-first-octal.txt + 08.again-second-octal.txt + 001.a.txt + 0010.reconfig.txt + 010.etc.txt + 005.etc.01.txt + 005.Etc.02.txt + 005.123.abc.txt + 200.somewhere.txt + 2zzzz.before-somewhere.txt + 00222-after-somewhere.txt + 005.00010.abc.txt + 005.a3423bc.00010.abc.txt + 005.001.abc.txt + 005.etc.1010.txt + 005.etc.010.txt + 005.etc.10.txt + " 005.etc.10.txt" + 005.etc.001.txt + 20.somewhere.txt + 4611686018427387904999999999-bignum.txt + 4611686018427387903-bigishnum.txt + 9223372036854775807-bigint.txt + etca-a + etc-a + etc2-a + a0001blah.txt + a010.txt + winlike-sort-difference-0.1.txt + winlike-sort-difference-0.1.1.txt + a1.txt + b1-a0001blah.txt + b1-a010.txt + b1-a1.txt + -a1.txt + --a1.txt + --a10.txt + 2.high-two.yml + 02.higher-two.yml + reconfig.txt + _common.stuff.txt + CASETEST.txt + casetest.txt + something.txt + some~thing.txt + someathing.txt + someThing.txt + thing.txt + thing_revised.txt + thing-revised.txt + "thing revised.txt" + "spacetest.txt" + " spacetest.txt" + " spacetest.txt" + "spacetest2.txt" + "spacetest 2.txt" + "spacetest02.txt" + name.txt + name2.txt + "name .txt" + "name2 .txt" + blah.txt + combined.txt + a001.txt + .test + .ssh + "Feb 10.txt" + "Feb 8.txt" + 1ab23v23v3r89ad8a8a8a9d.txt + "Folder (10)/file.tar.gz" + "Folder/file.tar.gz" + "Folder (1)/file (1).tar.gz" + "Folder (1)/file.tar.gz" + "Folder (01)/file.tar.gz" + "Folder1/file.tar.gz" + "Folder(1)/file.tar.gz" + + } + lappend testlist "Some file.txt" + lappend testlist " Some extra file1.txt" + lappend testlist " Some extra file01.txt" + lappend testlist " some extra file1.txt" + lappend testlist " Some extra file003.txt" + lappend testlist " Some file.txt" + lappend testlist "Some extra file02.txt" + lappend testlist "Program Files (x86)" + lappend testlist "01999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999991-bigger-pathologically-bignum.txt" + lappend testlist "199999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-pathologically-bignum.txt" + lappend testlist "29999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-smaller-pathologically-bignum.txt" + lappend testlist "199999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-pathologically-bignum.txt with (more 1.txt" + lappend testlist "199999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-pathologically-bignum.txt with (more 01.txt" + lappend testlist "a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1.pathological-num-nonnum-swapping-leadzero-should-be-first.txt" + lappend testlist "a1a1a1a1a1a1a1a1a1a1a1a01a1a1a1a1a1a1a1a1a1a1a1a1.pathological-num-nonnum-swapping-leadzero-should-be-first.txt" + lappend testlist "b1b1b1b1.txt" + lappend testlist "b1b01z1z1.txt" + lappend testlist "c1c111c1.txt" + lappend testlist "c1c1c1c1.txt" + + namespace eval overtype { + proc right {args} { + # @d !todo - implement overflow, length checks etc + + if {[llength $args] < 2} { + error {usage: ?-overflow [1|0]? undertext overtext} + } + foreach {undertext overtext} [lrange $args end-1 end] break + + set opt(-overflow) 0 + array set opt [lrange $args 0 end-2] + + + set olen [string length $overtext] + set ulen [string length $undertext] + + if {$opt(-overflow)} { + return [string range $undertext 0 end-$olen]$overtext + } else { + if {$olen > $ulen} { + set diff [expr {$olen - $ulen}] + return [string range $undertext 0 end-$olen][string range $overtext 0 end-$diff] + } else { + return [string range $undertext 0 end-$olen]$overtext + } + } + } + proc left {args} { + # @c overtype starting at left (overstrike) + # @c can/should we use something like this?: 'format "%-*s" $len $overtext + + if {[llength $args] < 2} { + error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} + } + foreach {undertext overtext} [lrange $args end-1 end] break + + set opt(-ellipsis) 0 + set opt(-ellipsistext) {...} + set opt(-overflow) 0 + array set opt [lrange $args 0 end-2] + + + set len [string length $undertext] + set overlen [string length $overtext] + set diff [expr {$overlen - $len}] + + #puts stdout "====================>overtype: datalen:$len overlen:$overlen diff:$diff" + #puts stdout "====================>overtype: data: $overtext" + if {$diff > 0} { + if {$opt(-overflow)} { + return $overtext + } else { + if {$opt(-ellipsis)} { + return [overtype::left [string range $overtext 0 [expr {$len -1}]] $opt(-ellipsistext)] + } else { + return [string range $overtext 0 [expr {$len -1}]] + } + } + } else { + return "$overtext[string range $undertext $overlen end]" + } + } + + } + + #considered using hex to make large numbers more compact for viewing in debug output - but it's not that much shorter and probably obscures more than it helps. + proc hex2dec {largeHex} { + set res 0 + set largeHex [string map [list _ ""] $largeHex] + foreach hexDigit [split $largeHex {}] { + set new 0x$hexDigit + set res [expr {16*$res + $new}] + } + return $res + } + proc dec2hex {decimalNumber} { + format %4.4llX $decimalNumber + } + proc trimzero {number} { + set trimmed [string trimleft $number 0] + if {[string length $trimmed] == 0} { + set trimmed 0 + } + return $trimmed + } + #todo - consider human numeric split + #e.g consider SI suffixes k|KMGTPEZY in that order + + #in this context, for natural sorting - numeric segments don't contain underscores or other punctuation such as . - + etc. + #review - what about unicode equivalents such as wide numerals \UFF10 to \UFF19? unicode normalization? + proc split_numeric_segments {name} { + set segments [list] + while {[string length $name]} { + if {[scan $name {%[0-9]%n} chunk len] == 2} { + lappend segments $chunk + set name [string range $name $len end] + } + if {[scan $name {%[^0-9]%n} chunk len] == 2} { + lappend segments $chunk + set name [string range $name $len end] + } + } + return $segments + } + + proc padleft {str count {ch " "}} { + set val [string repeat $ch $count] + append val $str + set diff [expr {max(0,$count - [string length $str])}] + set offset [expr {max(0,$count - $diff)}] + set val [string range $val $offset end] + } + + + # Sqlite may have limited collation sequences available in default builds. + # with custom builds - there may be others such as 'natsort' - see https://sqlite.org/forum/forumpost/e4dc6f3331 + # This is of limited use with the few builtin collations available in 2023 ie binary,nocase & rtrim + # but may provide a quicker,flexible sort option, especially if/when more collation sequences are added to sqlite + # There are also prebuilt packages such as sqlite3-icu which allows things like "SELECT icu_load_collation('en_AU', 'australian');" + proc sort_sqlite {stringlist args} { + package require sqlite3 + + + set args [check_flags -caller natsort_sqlite -defaults [list -db :memory: -collate nocase -winlike 0 -topchars "\uFFFF" -debug 0 -splitchars [list / . - _] -extras {all}] -values $args] + set db [string trim [dict get $args -db]] + set collate [string trim [dict get $args -collate]] + set debug [string trim [dict get $args -debug]] + set topchars [string trim [dict get $args -topchars]] + + set topdot [expr {"." in $topchars}] + set topunderscore [expr {"_" in $topchars}] + + + sqlite3 db_sort_basic $db + set orderedlist [list] + db_sort_basic eval [string map [list %collate% $collate] {create table sqlitesort(index0 text COLLATE %collate%, name text COLLATE %collate%)}] + foreach nm $stringlist { + set segments [split_numeric_segments $nm] + set index "" + set s 0 + foreach seg $segments { + if {($s == 0) && ![string length [string trim $seg]]} { + #don't index leading space + } elseif {($s == 0) && ($topunderscore) && [string match _* [string trim $seg]]} { + append index "[padleft "0" 5]-d -100 topunderscore " + append index [string trim $seg] + } elseif {($s == 0) && ($topdot) && [string match .* [string trim $seg]]} { + append index "[padleft "0" 5]-d -50 topdot " + append index [string trim $seg] + } else { + if {[string is digit [string trim $seg]]} { + set basenum [trimzero [string trim $seg]] + set lengthindex "[padleft [string length $basenum] 5]-d" + append index "$lengthindex " + #append index [padleft $basenum 40] + append index $basenum + } else { + append index [string trim $seg] + } + } + incr s + } + puts stdout ">>$index" + db_sort_basic eval {insert into sqlitesort values($index,$nm)} + } + db_sort_basic eval [string map [list %collate% $collate] {select name from sqlitesort order by index0 COLLATE %collate% ASC, name COLLATE %collate% ASC }] { + lappend orderedlist $name + } + db_sort_basic close + return $orderedlist + } + + proc get_leading_char_count {str char} { + #todo - something more elegant? regex? + set count 0 + foreach c [split $str "" ] { + if {$c eq $char} { + incr count + } else { + break + } + } + return $count + } + proc stacktrace {} { + set stack "Stack trace:\n" + for {set i 1} {$i < [info level]} {incr i} { + set lvl [info level -$i] + set pname [lindex $lvl 0] + append stack [string repeat " " $i]$pname + + if {![catch {info args $pname} pargs]} { + foreach value [lrange $lvl 1 end] arg $pargs { + + if {$value eq ""} { + if {$arg != 0} { + info default $pname $arg value + } + } + append stack " $arg='$value'" + } + } else { + append stack " !unknown vars for $pname" + } + + append stack \n + } + return $stack + } + + proc get_char_count {str char} { + expr {[string length $str]-[string length [string map [list $char {}] $str]]} + } + + proc build_key {chunk splitchars topdict tagconfig debug} { + variable stacktrace_on + if {$stacktrace_on} { + puts stderr "+++>[stacktrace]" + } + + set index_map [list - "" _ ""] + #e.g - need to maintain the order + #a b.txt + #a book.txt + #ab.txt + #abacus.txt + + + set original_splitchars [dict get $tagconfig original_splitchars] + + # tag_dashes test moved from loop - review + set tag_dashes 0 + if {![string length [dict get $tagconfig last_part_text_tag]]} { + #winlike + set tag_dashes 1 + } + if {("-" ni $original_splitchars)} { + set tag_dashes 1 + } + if {$debug >= 3} { + puts stdout "START build_key chunk : $chunk" + puts stdout "START build_key splitchars : $splitchars $topdict $tagconfig NO tag dashes" + } + + + ## index_map will have no effect if we've already split on the char anyway(?) + #foreach m [dict keys $index_map] { + # if {$m in $original_splitchars} { + # dict unset index_map $m + # } + #} + + #if {![string length $chunk]} return + + set result "" + if {![llength $splitchars]} { + #no more structural splits - but we need to examine numeric/non-numeric segments at the lowest level. + # we are at a leaf in the recursive split hierarchy + + set s "" ;#we never actually split on "" (unless that was put in splitchars.. but it probably shouldn't be) + set parts [list $chunk] ;#important to treat as list or leading/trailing whitespace lost + + + } else { + set s [lindex $splitchars 0] + if {"spudbucket$s" in "[split $chunk {}]"} { + error "dead-branch spudbucket" + set partindex [build_key $chunk [lrange $splitchars 1 end] $topdict $tagconfig $debug] + if {[dict get $tagconfig showsplits]} { + set pfx "(1${s}=)" ;# = sorts before _ + set partindex ${pfx}$partindex + } + + return $partindex + } else { + set parts_below_index "" + + if {$s ni [split $chunk ""]} { + #$s can be an empty string + set parts [list $chunk] + } else { + set parts [split $chunk $s] ;#whitespace preserved - even if splitting on s that is not in string. + } + #assert - we have a splitchar $s that is in the chunk - so at least one part + if {(![string length $s] || [llength $parts] == 0)} { + error "buld_key assertion false empty split char and/or no parts" + } + + set pnum 1 ;# 1 based for clarity of reading index in debug output + set subpart_count [llength $parts] + + set sub_splits [lrange $splitchars 1 end] ;#pass same splitchars to each subpart + foreach p $parts { + set partindex [build_key $p $sub_splits $topdict $tagconfig $debug] + set lastpart [expr {$pnum == $subpart_count}] + + + ####################### + set showsplits [dict get $tagconfig showsplits] + #split prefixing experiment - maybe not suitable for general use - as it affects sort order + #note that pfx must be consistent until last one, no matter how many partnumbers there are in total. + # we don't want to influence sort order before reaching end. + #e.g for: + #(1.=)... + #(1._)...(2._)...(3.=) + #(1._)...(2.=) + #Note that this is probably more suitable for highly structure dependant sorts where the results are maybe less.. natural. + if {$showsplits} { + if {$lastpart} { + set pfx "(${pnum}${s}_" + #set pfx "(${pnum}${s}=)" ;# = sorts before _ + } else { + set pfx "(${pnum}${s}_" + } + append parts_below_index $pfx + } + ####################### + + if {$lastpart} { + if {[string length $p] && [string is digit $p]} { + set last_part_tag "<22${s}>" + } else { + set last_part_tag "<33${s}>" + } + + set last_part_text_tag [dict get $tagconfig last_part_text_tag] + #for -winlike 1 there is no tag configured. Windows explorer likes to put things in the order: + # module-0.1.1.tm + # module-0.1.1.2.tm + # module-0.1.tm + # arguably -winlike 0 is more natural/human + # module-0.1.tm + # module-0.1.1.tm + # module-0.1.1.2.tm + + if {[string length $last_part_text_tag]} { + #replace only the first text-tag (<30>) from the subpart_index + if {[string match "<30?>*" $partindex]} { + #give textual string index a specific tag for last part in split only. e.g <130> for lower than integers + set partindex "<130>[string range $partindex 5 end]" + } + #append parts_below_index $last_part_tag + } + #set partindex $last_part_tag$partindex + + + } + append parts_below_index $partindex + + + + if {$showsplits} { + if {$lastpart} { + set suffix "${pnum}${s}=)" ;# = sorts before _ + } else { + set suffix "${pnum}${s}_)" + } + append parts_below_index $suffix + } + + + incr pnum + } + append parts_below_index "" ;# don't add anything at the tail that may perturb sort order + + if {$debug >= 3} { + set pad [string repeat " " 20] + puts stdout "END build_key chunk : $chunk " + puts stdout "END build_key splitchars : $splitchars $topdict $tagconfig NO tag dashes" + puts stdout "END build_key ret below_index: $parts_below_index" + } + return $parts_below_index + + + } + } + + + + #puts stdout ">>>chunk:'$chunk'<<< split-on:$s parts: '$parts' splitchars: $splitchars -topdict:$topdict" + + + + + + #if {$chunk eq ""} { + # puts "___________________________________________!!!____" + #} + #puts stdout "-->chunk:$chunk $s parts:$parts" + + #puts stdout "---chunk:'$chunk' part:'$part' parts:'$parts' s:'$s'" + + + + + set segments [split_numeric_segments $chunk] ;#! + set stringindex "" + set segnum 0 + foreach seg $segments { + #puts stdout "=================---->seg:$seg segments:$segments" + #-strict ? + if {[string length $seg] && [string is digit $seg]} { + set basenum [trimzero [string trim $seg]] + set lengthindex "[padleft [string length $basenum] 4]d" + #append stringindex "<20>$lengthindex $basenum $seg" + } else { + set c1 [string range $seg 0 0] + #puts stdout "==============> c1'$c1' topdict: $topdict stringindex:$stringindex" + + if {$c1 in [dict keys $topdict]} { + set tag [dict get $topdict $c1] + #append stringindex "${tag}$c1" + #set seg [string range $seg 1 end] + } + #textindex + set leader "<30>" + set idx $seg + set idx [string trim $idx] + set idx [string tolower $idx] + set idx [string map $index_map $idx] + + + + + + #set the X-c count to match the length of the index - not the raw data + set lengthindex "[padleft [string length $idx] 4]c" + + #append stringindex "${leader}$idx $lengthindex $texttail" + } + } + + if {[llength $parts] != 1} { + error "build_key assertion fail llength parts != 1 parts:$parts" + } + + set segtail_clearance_buffer " " ;#space to clear other split indicators if using showsplits + set segtail $segtail_clearance_buffer + append segtail "\[" + set grouping "" + set pnum 0 + foreach p $parts { + set sublen_list [list] + set subsegments [split_numeric_segments $p] + set i 0 + + set partsorter "" + foreach sub $subsegments { + ##don't trim spaces here - it would be inconsistent. Some subs are pure whitespace - others have internal whitespace. e.g "a4 400b a b2" becomes "a 4 { } 400 {b a b} 2" + #mapping away all whitespace would be consistent, but not necessarily desirable. If it's in the index_map it'll happen anyway - so we don't do it manually here except for evaluating conditions. + set test_trim [string trim $sub] + set str $sub + set str [string tolower $str] + set str [string map $index_map $str] + if {[string length $test_trim] && [string is digit $test_trim]} { + append partsorter [trimzero $str] + } else { + append partsorter "$str" + } + append partsorter + } + + + foreach sub $subsegments { + + if {[string length $sub] && [string is digit $sub]} { + set basenum [trimzero [string trim $sub]] + set subequivs $basenum + set lengthindex "[padleft [string length $subequivs] 4]d " + set idx "$lengthindex [padleft $basenum 10]" ;#todo - cycle through data and determine longest + set tail [overtype::left [string repeat " " 10] $sub] + #set tail "" + } else { + set idx "" + + + set lookahead [lindex $subsegments $i+1] + if {![string length $lookahead]} { + set zeronum "[padleft 0 4]d0" + } else { + set zeronum "" + } + set subequivs $sub + #set subequivs [string trim $subequivs] + set subequivs [string tolower $subequivs] + set subequivs [string map $index_map $subequivs] + + append idx $subequivs + append idx $zeronum + + set idx $subequivs + + + # + + set ch "-" + if {$tag_dashes} { + #puts stdout "____TAG DASHES" + #winlike + set numleading [get_leading_char_count $seg $ch] + if {$numleading > 0} { + set texttail "<31-leading[padleft $numleading 4]$ch>" + } else { + set texttail "<30>" + } + set numothers [expr {[get_char_count $seg $ch] - $numleading}] + if {$debug >= 2} { + puts stdout "____dashcount: [get_char_count $seg $ch] numothers: $numothers" + } + if {$numothers > 0} { + append texttail "<31-others[padleft $numothers 4]$ch>" + } else { + append textail "<30>" + } + } else { + set texttail "<30>" + } + + + + + #set idx $partsorter + set tail "" + #set tail [string tolower $sub] ;#raw + #set tail $partsorter + #append tail ":[string tolower $p]" ;#we need the whole part - even though it makes the index much larger. !todo - tagconfig switch to toggle case sensitive sorting + } + + append grouping "$idx $tail|$s" + incr i + } + + + + + + if {$p eq ""} { + # no subsegments.. + set zeronum "[padleft 0 4]d0" + #append grouping "\u000$zerotail" + append grouping ".$zeronum" + } + + #append grouping | + #append grouping $s + #foreach len $sublen_list { + # append segtail "<[padleft $len 3]>" + #} + incr pnum + } + set grouping [string trimright $grouping $s] + append grouping "[padleft [llength $parts] 4]" + append segtail $grouping + + + #append segtail " <[padleft [llength $parts] 4]>" + + append segtail "\]" + + + #if {[string length $seg] && [string is digit $seg]} { + # append segtail "<20>" + #} else { + # append segtail "<30>" + #} + append stringindex $segtail + + incr segnum + + + + + lappend indices $stringindex + + if {[llength $indices] > 1} { + puts stderr "INDICES [llength $indices]: $stringindex" + error "build_key assertion error deadconcept indices" + } + + #topchar handling on splitter characters + #set c1 [string range $chunk 0 0] + if {$s in [dict keys $topdict]} { + set tag [dict get $topdict $s] + set joiner [string map [list ">" "$s>"] ${tag}] + #we have split on this character $s so if the first part is empty string then $s was a leading character + # we need to bring a tag out front for this, or it will be dominated by the leading sections-remaing tag + # (since the empty string produces no tag of it's own - ?) + if {[string length [lindex $parts 0]] == 0} { + set prefix ${joiner} + } else { + set prefix "" + } + } else { + #use standard character-data positioning tag if no override from topdict + set joiner "<30J>$s" + set prefix "" + } + + + set contentindex $prefix[join $indices $joiner] + if {[string length $s]} { + set split_indicator "" + } else { + set split_indicator "" + + } + if {![string length $s]} { + set s ~ + } + + #return "[overtype::left [string repeat { } 80] $contentindex][overtype::left [string repeat { } 10] [list $s $chunk]]" + #return $contentindex$split_indicator + #return [overtype::left [string repeat - 40] $contentindex] + + if {$debug >= 3} { + puts stdout "END build_key chunk : $chunk" + puts stdout "END build_key splitchars : $splitchars $topdict $tagconfig NO tag dashes" + puts stdout "END build_key ret contentidx : $contentindex" + } + return $contentindex + } + + #---------------------------------------- + #line-processors - data always last argument - opts can be empty string + #all processor should accept empty opts and ignore opts if they don't use them + proc _lineinput_as_tcl1 {opts line} { + set out "" + foreach i $line { + append out "$i " + } + set out [string range $out 0 end-1] + return $out + } + #should be equivalent to above + proc _lineinput_as_tcl {opts line} { + return [concat {*}$line] + } + #will put extra tcl quoting if it was already tcl-shaped e.g text "a" -> {"a"} + proc _lineoutput_as_tcl {opts line} { + return [regexp -inline -all {\S+} $line] + } + + proc _lineinput_as_raw {opts line} { + return $line + } + proc _lineoutput_as_raw {opts line} { + return $line + } + + #words is opposite of tcl + proc _lineinput_as_words {opts line} { + #wordlike_parts + return [regexp -inline -all {\S+} $line] + } + proc _lineoutput_as_words {opts line} { + return [concat {*}$line] + } + + #opts same as tcllib csv::split - except without the 'line' element + #?-alternate? ?sepChar? ?delChar? + proc _lineinput_as_csv {opts line} { + package require csv + if {[lindex $opts 0] eq "-alternate"} { + return [csv::split -alternate $line {*}[lrange $opts 1 end]] + } else { + return [csv::split $line {*}$opts] + } + } + #opts same as tcllib csv::join + #?sepChar? ?delChar? ?delMode? + proc _lineoutput_as_csv {opts line} { + package require csv + return [csv::join $line {*}$opts] + } + #---------------------------------------- + proc sort {stringlist args} { + #puts stdout "natsort::sort args: $args" + variable debug + if {![llength $stringlist]} return + + #allow pass through of the check_flags flag -debugargs so it can be set by the caller + set debugargs 0 + if {[set posn [lsearch $args -debugargs]] >=0} { + if {$posn == [llength $args]-1} { + #-debugargs at tail of list + set debugargs 1 + } else { + set debugargs [lindex $args $posn+1] + } + } + + #-return flagged|defaults doesn't work Review. + #flagfilter global processor/allocator not working 2023-08 + set args [check_flags \ + -caller natsort::sort \ + -return supplied|defaults \ + -debugargs $debugargs \ + -defaults [list -collate nocase \ + -winlike 0 \ + -splits "\uFFFF" \ + -topchars {. _} \ + -showsplits 1 \ + -sortmethod ascii \ + -collate "\uFFFF" \ + -inputformat raw \ + -inputformatapply {index data} \ + -inputformatoptions "" \ + -outputformat raw \ + -outputformatoptions "" \ + -cols "\uFFFF" \ + -debug 0 -db "" -stacktrace 0 -splits "\uFFFF" -showsplits 0] \ + -required {all} \ + -extras {none} \ + -commandprocessors {} \ + -values $args] + + #csv unimplemented + + set winlike [dict get $args -winlike] + set topchars [dict get $args -topchars] + set cols [dict get $args -cols] + set debug [dict get $args -debug] + set stacktrace [dict get $args -stacktrace] + set showsplits [dict get $args -showsplits] + set splits [dict get $args -splits] + set sortmethod [dict get $args -sortmethod] + set opt_collate [dict get $args -collate] + set opt_inputformat [dict get $args -inputformat] + set opt_inputformatapply [dict get $args -inputformatapply] + set opt_inputformatoptions [dict get $args -inputformatoptions] + set opt_outputformat [dict get $args -outputformat] + set opt_outputformatoptions [dict get $args -outputformatoptions] + dict unset args -showsplits + dict unset args -splits + if {$debug} { + puts stdout "natsort::sort processed_args: $args" + if {$debug == 1} { + puts stdout "natsort::sort - try also -debug 2, -debug 3" + } + } + + #set sortmethod "-dictionary" ;# sorts a2b before a001b - possibly other strangenesses that are hard to reason about + + if {$sortmethod in [list dictionary ascii]} { + set sortmethod "-$sortmethod" + # -ascii is default for tcl lsort. + } else { + set sortmethod "-ascii" + } + + set allowed_collations [list nocase] + if {$opt_collate ne "\uFFFF"} { + if {$opt_collate ni $allowed_collations} { + error "natsort::sort unknown value for -collate option. Only acceptable value(s): $allowed_collations" + } + set nocaseopt "-$opt_collate" + } else { + set nocaseopt "" + } + set allowed_inputformats [list tcl raw csv words] + if {$opt_inputformat ni $allowed_inputformats} { + error "natsort::sort unknown value for -inputformat option. Only acceptable value(s): $allowed_inputformats" + } + set allowed_outputformats [list tcl raw csv words] + if {$opt_inputformat ni $allowed_outputformats} { + error "natsort::sort unknown value for -outputformat option. Only acceptable value(s): $allowed_outputformats" + } + + # + set winsplits [list / . _] + set commonsplits [list / . _ -] + #set commonsplits [list] + + set tagconfig [dict create] + dict set tagconfig last_part_text_tag "<19>" + if {$winlike} { + set splitchars $winsplits + #windows explorer sorts leading spaces at the top - which doesn't seem very helpful for keeping things together - but the explorer doesn't seem able to create leading spaces anyway. + set wintop [list "(" ")" { } {.} {_}] ;#windows specific order + foreach t $topchars { + if {$t ni $wintop} { + lappend wintop $t + } + } + set topchars $wintop + dict set tagconfig last_part_text_tag "" + } else { + set splitchars $commonsplits + } + if {$splits ne "\uFFFF"} { + set splitchars $splits + } + dict set tagconfig original_splitchars $splitchars + dict set tagconfig showsplits $showsplits + + #create topdict + set i 0 + set topdict [dict create] + foreach c $topchars { + incr i ;#start at 01 so that 00 reserved for final-split tag (allows x-0.1.txt to sort above x-0.1.1.txt by default. Use tagconfig to change, or choose -winlike 1 for explorer-like sorting) + dict set topdict $c "<0$i>" + } + set keylist [list] + + + if {$opt_inputformat eq "tcl"} { + set lineinput_transform [list _lineinput_as_tcl $opt_inputformatoptions] + } elseif {$opt_inputformat eq "csv"} { + set lineinput_transform [list _lineinput_as_csv $opt_inputformatoptions] + } elseif {$opt_inputformat eq "raw"} { + set lineinput_transform [list _lineinput_as_raw $opt_inputformatoptions] + } elseif {$opt_inputformat eq "words"} { + set lineinput_transform [list _lineinput_as_words $opt_inputformatoptions] + } + if {$opt_outputformat eq "tcl"} { + set lineoutput_transform [list _lineoutput_as_tcl $opt_outputformatoptions] + } elseif {$opt_outputformat eq "csv"} { + set lineoutput_transform [list _lineoutput_as_csv $opt_outputformatoptions] + } elseif {$opt_outputformat eq "raw"} { + set lineoutput_transform [list _lineoutput_as_raw $opt_outputformatoptions] + } elseif {$opt_outputformat eq "words"} { + set lineoutput_transform [list _lineoutput_as_words $opt_outputformatoptions] + } + + + if {("data" in $opt_inputformatapply) || ("index" in $opt_inputformatapply)} { + if {$opt_inputformat eq "raw"} { + set tf_stringlist $stringlist + } else { + set tf_stringlist [list] + foreach v $stringlist { + lappend tf_stringlist [{*}$lineinput_transform $v] + } + } + if {"data" in $opt_inputformatapply} { + set tf_data_stringlist $tf_stringlist + } else { + set tf_data_stringlist $stringlist + } + if {"index" in $opt_inputformatapply} { + set tf_index_stringlist $tf_stringlist + } else { + set tf_index_stringlist $stringlist + } + } else { + set tf_data_stringlist $stringlist + set tf_index_stringlist $stringlist + } + + + + if {$stacktrace} { + puts stdout [natsort::stacktrace] + set natsort::stacktrace_on 1 + } + if {$cols eq "\uFFFF"} { + set colkeys [lmap v $stringlist {}] + } else { + set colkeys [list] + foreach v $tf_index_stringlist { + set lineparts $v + set k [list] + foreach c $cols { + lappend k [lindex $lineparts $c] + } + lappend colkeys [join $k "_"] ;#use a common-split char - Review + } + } + #puts stdout "colkeys: $colkeys" + + if {$opt_inputformat eq "raw"} { + #no inputformat was applied - can just use stringlist + foreach value $stringlist ck $colkeys { + set contentindex [build_key $value $splitchars $topdict $tagconfig $debug] + set colindex [build_key $ck $splitchars $topdict $tagconfig $debug] + lappend keylist ${colindex}-${contentindex}-$value ;#note: entire raw value used for final sort disambiguation (can be whitespace that was ignored in indexing) + } + } else { + foreach keyinput $tf_index_stringlist datavalue $tf_data_stringlist ck $colkeys { + #data may or may not have been transformed + #column index may or may not have been built with transformed data + + set contentindex [build_key $keyinput $splitchars $topdict $tagconfig $debug] + set colindex [build_key $ck $splitchars $topdict $tagconfig $debug] + lappend keylist ${colindex}-${contentindex}-$datavalue ;#note: entire value used for final sort disambiguation (can be whitespace that was ignored in indexing) + } + } + #puts stderr "keylist: $keylist" + + ################################################################################################### + # Use the generated keylist to do the actual sorting + # select either the transformed or raw data as the corresponding output + ################################################################################################### + if {[string length $nocaseopt]} { + set sortcommand [list lsort $sortmethod $nocaseopt -indices $keylist] + } else { + set sortcommand [list lsort $sortmethod -indices $keylist] + } + if {$opt_outputformat eq "raw"} { + #raw output means no further transformations - it doesn't mean there wasn't a transform applied on the input side + #use the tf_data_stringlist in the output - which will be the same as the input stringlist if no input transform applied for data. + #(Also - it may or may not have been *sorted* on transformed data depending on whether 'index' was in $opt_inputformatapply) + foreach idx [{*}$sortcommand] { + lappend result [lindex $tf_data_stringlist $idx] + } + } else { + #we need to apply an output format + #The data may or may not have been transformed at input + foreach idx [{*}$sortcommand] { + lappend result [{*}$lineoutput_transform [lindex $tf_data_stringlist $idx]] + } + } + ################################################################################################### + + + + + + if {$debug >= 2} { + set screen_width 250 + set max_val 0 + set max_idx 0 + ##### calculate colum widths + foreach i [{*}$sortcommand] { + set len_val [string length [lindex $stringlist $i]] + if {$len_val > $max_val} { + set max_val $len_val + } + set len_idx [string length [lindex $keylist $i]] + if {$len_idx > $max_idx} { + set max_idx $len_idx + } + } + #### + set l_width [expr {$max_val + 1}] + set leftcol [string repeat " " $l_width] + set r_width [expr {$screen_width - $l_width - 1}] + set rightcol [string repeat " " $r_width] + set str [overtype::left $leftcol RAW] + puts stdout " $str Index with possibly transformed data at tail" + foreach i [{*}$sortcommand] { + #puts stdout "|d> [overtype::left $leftcol [lindex $stringlist $i] ] [lindex $keylist $i]" + set index [lindex $keylist $i] + set len_idx [string length $index] + set rowcount [expr {$len_idx / $r_width}] + if {($len_idx % $r_width) > 0} { + incr rowcount + } + set rows [list] + for {set r 0} {$r < $rowcount} {incr r} { + lappend rows [string range $index 0 $r_width-$r] + set index [string range $index $r_width end] + } + + set r 0 + foreach idxpart $rows { + if {$r == 0} { + #use the untransformed stringlist + set str [overtype::left $leftcol [lindex $stringlist $i]] + } else { + set str [overtype::left $leftcol ...]] + } + puts stdout " $str $idxpart" + incr r + } + #puts stdout "|> '[lindex $stringlist $i]'" + #puts stdout "|> [lindex $keylist $i]" + } + + puts stdout "|debug> topdict: $topdict" + puts stdout "|debug> splitchars: $splitchars" + } + return $result + } + + + + #Note that although leading whitespace isn't a commonly used feature of filesystem names - it's possible at least on FreeBSD,windows and linux so we should try to handle it sensibly. + proc sort_experiment {stringlist args} { + package require sqlite3 + + variable debug + set args [check_flags -caller natsort::sort \ + -defaults [dict create -db :memory: -collate nocase -nullvalue "->NULL<" -winlike 0 -topchars [list] -debug 0] \ + -extras {all} \ + -values $args] + set db [string trim [dict get $args -db]] + set collate [string trim [dict get $args -collate]] + set winlike [string trim [dict get $args -winlike]] + set debug [string trim [dict get $args -debug]] + set nullvalue [string trim [dict get $args -nullvalue]] + + + set topchars [string trim [dict get $args -topchars]] + + set topdot [expr {"." in $topchars}] + set topunderscore [expr {"_" in $topchars}] + + + sqlite3 db_natsort2 $db + #-- + #our table must handle the name with the greatest number of numeric/non-numeric splits. + #This means a single list member with pathological naming e.g a1a1a1a1a1a1a1a1a1a1a1.txt could greatly extend the number of columns and indices and affect performance. + #review: could be optimised to aggregate the tail into a single index, as the the extra columns won't assist in ordering, but make the table and query bigger. + # we should probably determine the longest common sequence of splits in the input list and add only one more index for the segment after that. + set maxsegments 0 + #-- + set prefix "idx" + + #note - there will be more columns in the sorting table than segments. + # (a segment equals one of the numeric & non-numeric string portions returned from 'split_numeric_sgements') + #--------------------------- + # consider + # a123b.v1.2.txt + # a123b.v1.3beta1.txt + # these have the following segments: + # a 123 b.v 1 . 2 .txt + # a 123 b.v 1 . 3 beta 1 .txt + #--------------------------- + # The first string has 7 segments (numbered 0 to 6) + # the second string has 9 segments + # + # for example when the data has any elements in a segment position that are numeric (e.g 0001 123) + # - then an index column with numeric equivalents will be created (e.g 0001 becomes 1), and any non-numeric values in that column will get mapped to a negative value (for special cases) or a high value such as NULL (with NULLS LAST sql support) + # + # when a segment + + #cycle through all strings - we cannot build tabledef as we go because the column type depends on whether all segments for a particular column are text vs int-equivalent. + array set segmentinfo {} + foreach nm $stringlist { + set segments [split_numeric_segments $nm] + if {![string length [string trim [lindex $segments 0]]]} { + if {[string is digit [string trim [lindex $segments 1]]]} { + #name is whitespace followed by a digit - special case - ignore the whitespace for numbers only. (whitespace still goes through to name column though) + set segments [lrange $segments 1 end] + } + } + + + set c 0 ;#start of index columns + if {[llength $segments] > $maxsegments} { + set maxsegments [llength $segments] + } + foreach seg $segments { + set seg [string trim $seg] + set column_exists [info exists segmentinfo($c,type)] + if {[string is digit $seg]} { + if {$column_exists} { + #override it (may currently be text or int) + set segmentinfo($c,type) "int" + } else { + #new column + set segmentinfo($c,name) ${prefix}$c + set segmentinfo($c,type) "int" + } + } else { + #text never overrides int + if {!$column_exists} { + set segmentinfo($c,name) ${prefix}$c + set segmentinfo($c,type) "text" + } + } + incr c + } + } + if {$debug} { + puts stdout "Largest number of num/non-num segments in data: $maxsegments" + #parray segmentinfo + } + + # + set tabledef "" + set ordered_column_names [list] + set ordered_segmentinfo_tags [lsort -dictionary [array names segmentinfo *]] + foreach k $ordered_segmentinfo_tags { + lassign [split $k ,] c tag + if {$tag eq "type"} { + set type [set segmentinfo($k)] + if {$type eq "int"} { + append tabledef "$segmentinfo($c,name) int," + } else { + append tabledef "$segmentinfo($c,name) text COLLATE $collate," + } + append tabledef "raw$c text COLLATE $collate," + lappend ordered_column_names $segmentinfo($c,name) + lappend ordered_column_names raw$c ;#additional index column not in segmentinfo + } + if {$tag eq "name"} { + #lappend ordered_column_names $segmentinfo($k) + } + } + append tabledef "name text" + + #puts stdout "tabledef:$tabledef" + + + db_natsort2 eval [string map [list %tabledef% $tabledef] {create table natsort(%tabledef%)}] + + + foreach nm $stringlist { + array unset intdata + array set intdata {} + array set rawdata {} + #init array and build sql values string + set sql_insert "insert into natsort values(" + for {set i 0} {$i < $maxsegments} {incr i} { + set intdata($i) "" + set rawdata($i) "" + append sql_insert "\$intdata($i),\$rawdata($i)," + } + append sql_insert "\$nm" ;#don't manipulate name value in any way - e.g must leave all whitespace as the sort must return exactly the same elements as in the original list. + append sql_insert ")" + + set segments [split_numeric_segments $nm] + if {![string length [string trim [lindex $segments 0]]]} { + if {[string is digit [string trim [lindex $segments 1]]]} { + #name is whitespace followed by a digit - special case - ignore the whitespace for numbers only. (whitespace still goes through to name column though) + set segments [lrange $segments 1 end] + } + } + set values "" + set c 0 + foreach seg $segments { + if {[set segmentinfo($c,type)] eq "int"} { + if {[string is digit [string trim $seg]]} { + set intdata($c) [trimzero [string trim $seg]] + } else { + catch {unset intdata($c)} ;#set NULL - sorts last + if {($c == 0) && ($topunderscore) && [string match _* [string trim $seg]]} { + set intdata($c) -100 + } + if {($c == 0) && ($topdot) && [string match .* [string trim $seg]]} { + set intdata($c) -50 + } + } + set rawdata($c) [string trim $seg] + } else { + #pure text column + #set intdata($c) [string trim $seg] ;#ignore leading/trailing whitespace - we sort first on trimmed version, then refine with the sort on rawdata index + #catch {unset indata($c)} + set indata($c) [string trim $seg] + set rawdata($c) $seg + } + #set rawdata($c) [string trim $seg]# + #set rawdata($c) $seg + incr c + } + db_natsort2 eval $sql_insert + } + + set orderedlist [list] + + if {$debug} { + db_natsort2 eval {select * from pragma_table_info('natsort')} rowdata { + parray rowdata + } + } + set orderby "order by " + + foreach cname $ordered_column_names { + if {[string match "idx*" $cname]} { + append orderby "$cname ASC NULLS LAST," + } else { + append orderby "$cname ASC," + } + } + append orderby " name ASC" + #append orderby " NULLS LAST" ;#?? + + #e.g "order by idx0 ASC, raw0 ASC, idx1 ASC .... name ASC" + if {$debug} { + puts stdout "orderby clause: $orderby" + } + db_natsort2 eval [string map [list %orderby% $orderby] {select * from natsort %orderby%}] rowdata { + set line "- " + #parray rowdata + set columnnames $rowdata(*) + #puts stdout "columnnames: $columnnames" + #[lsort -dictionary [array names rowdata] + append line "$rowdata(name) \n" + foreach nm $columnnames { + if {$nm ne "name"} { + append line "$nm: $rowdata($nm) " + } + } + #puts stdout $line + #puts stdout "$rowdata(name)" + lappend orderedlist $rowdata(name) + } + + db_natsort2 close + return $orderedlist + } +} + + +#application section e.g this file might be linked from /usr/local/bin/natsort +namespace eval natsort { + namespace import ::flagfilter::check_flags + + proc called_directly_namematch {} { + global argv0 + #see https://wiki.tcl-lang.org/page/main+script + #trailing ... let's us resolve symlinks in last component of the path (could be something else like ___ but ... seems unlikely to collide with anything in the filesystem) + if {[info exists argv0] + && + [file dirname [file normalize [file join [info script] ...]]] + eq + [file dirname [file normalize [file join $argv0 ...]]] + } { + return 1 + } else { + #puts stdout "norm info script: [file dirname [file normalize [file join [info script] ...]]]" + #puts stdout "norm argv0 : [file dirname [file normalize [file join $argv0 ...]]]" + return 0 + } + } + #Review issues around comparing names vs using inodes (esp with respect to samba shares) + proc called_directly_inodematch {} { + global argv0 + if {[info exists argv0] + && [file exists [info script]] && [file exists $argv0]} { + file stat $argv0 argv0Info + file stat [info script] scriptInfo + expr {$argv0Info(dev) == $scriptInfo(dev) + && $argv0Info(ino) == $scriptInfo(ino)} + } else { + return 0 + } + } + + set is_namematch [called_directly_namematch] + set is_inodematch [called_directly_inodematch] + #### + #review - reliability of mechanisms to determine direct calls + # we don't want application being called when being used as a library, but we need it to run if called directly or from symlinks etc + #-- choose a policy and leave the others commented. + #set is_called_directly $is_namematch + #set is_called_directly $is_inodematch + set is_called_directly [expr {$is_namematch || $is_inodematch}] + #set is_called_directly [expr {$is_namematch && $is_inodematch}] + ### + + + #puts stdout "called_directly_name: [called_directly_namematch] called_directly_inode: [called_directly_inodematch]" + + + # + + + proc test_pass_fail_message {pass {additional ""}} { + variable test_fail_msg + variable test_pass_msg + if {$pass} { + puts stderr $test_pass_msg + } else { + puts stderr $test_fail_msg + } + puts stderr $additional + } + + variable test_fail_msg "XXXXXXXXXXXX FAIL XXXXXXXXXXXXX" + variable test_pass_msg "------------ PASS -------------" + proc test_sort_1 {args} { + package require struct::list + puts stderr "---$args" + set args [check_flags -caller natsort:test_sort_1 -defaults [list -collate nocase -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 ] -values $args] + + puts stderr "test_sort_1 got args: $args" + + set unsorted_input { + 2.2.2 + 2.2.2.2 + 1a.1.1 + 1a.2.1.1 + 1.12.1 + 1.2.1.1 + 1.02.1.1 + 1.002b.1.1 + 1.1.1.2 + 1.1.1.1 + } + set input { +1.1.1 +1.1.1.2 +1.002b.1.1 +1.02.1.1 +1.2.1.1 +1.12.1 +1a.1.1 +1a.2.1.1 +2.2.2 +2.2.2.2 + } + + set sorted [natsort::sort $input {*}$args] + set is_match [struct::list equal $input $sorted] + + set msg "windows-explorer order" + + test_pass_fail_message $is_match $msg + puts stdout [string repeat - 40] + puts stdout INPUT + puts stdout [string repeat - 40] + foreach item $input { + puts stdout $item + } + puts stdout [string repeat - 40] + puts stdout OUTPUT + puts stdout [string repeat - 40] + foreach item $sorted { + puts stdout $item + } + test_pass_fail_message $is_match $msg + return [expr {!$is_match}] + } + proc test_sort_showsplits {args} { + package require struct::list + + set args [check_flags -caller natsort:test_sort_1 \ + -defaults [list -collate nocase -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 1 ] \ + -extras {all} \ + -values $args] + + set input1 { + a-b.txt + a.b.c.txt + b.c-txt + } + + + set input2 { + a.b.c.txt + a-b.txt + b.c-text + } + + foreach {msg testlist } [list "custom-order" $input1 "windows-explorer (should work with -winlike 1)" $input2] { + set sorted [natsort::sort $testlist {*}$args] + set is_match [struct::list equal $testlist $sorted] + + test_pass_fail_message $is_match $msg + puts stderr "INPUT" + puts stderr "[string repeat - 40]" + foreach item $testlist { + puts stdout $item + } + puts stderr "[string repeat - 40]" + puts stderr "OUTPUT" + puts stderr "[string repeat - 40]" + foreach item $sorted { + puts stdout $item + } + + test_pass_fail_message $is_match $msg + } + + #return [expr {!$is_match}] + + } + + #tcl dispatch order - non flag items up front + #trailing flags are paired even if supplied as solo flags e.g -l becomes -l 1 + proc commandline_ls {args} { + set operands [list] + set posn 0 + foreach a $args { + if {![string match -* $a]} { + lappend operands $a + } else { + set flag1_posn $posn + break + } + incr posn + } + set args [lrange $args $flag1_posn end] + + + set debug 0 + set posn [lsearch $args -debug] + if {$posn > 0} { + if {[lindex $args $posn+1]} { + set debug [lindex $args $posn+1] + } + } + if {$debug} { + puts stderr "|debug>commandline_ls got $args" + } + + #if first operand not supplied - replace it with current working dir + if {[lindex $operands 0] eq "\uFFFF"} { + lset operands 0 [pwd] + } + + set targets [list] + foreach op $operands { + if {$op ne "\uFFFF"} { + set opchars [split [file tail $op] ""] + if {"?" in $opchars || "*" in $opchars} { + lappend targets $op + } else { + #actual file or dir + set targetitem $op + set targetitem [file normalize $op] + if {![file exists $targetitem]} { + if {$debug} { + puts stderr "|debug>commandline_ls Unable to access path '$targetitem'" + } + } + lappend targets $targetitem + if {$debug} { + puts stderr "|debug>commandline_ls listing for $targetitem" + } + } + } + } + set args [check_flags -caller commandline_ls \ + -return flagged|defaults \ + -debugargs 0 \ + -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 -algorithm sort] \ + -required {all} \ + -extras {all} \ + -soloflags {-v -l} \ + -commandprocessors {} \ + -values $args ] + if {$debug} { + puts stderr "|debug>args: $args" + } + + + set algorithm [dict get $args -algorithm] + dict unset args -algorithm + + set allfolders [list] + set allfiles [list] + foreach item $targets { + if {[file exists $item]} { + if {[file type $item] eq "directory"} { + set dotfolders [glob -nocomplain -directory $item -type {d} -tail .*] + set folders [glob -nocomplain -directory $item -type {d} -tail *] + set allfolders [concat $allfolders $dotfolders $folders] + + set dotfiles [glob -nocomplain -directory $item -type {f} -tail .*] + set files [glob -nocomplain -directory $item -type {f} -tail *] + set allfiles [concat $allfiles $dotfiles $files] + } else { + #file (or link?) + set files [glob -nocomplain -directory [file dirname $item] -tail [file tail $item]] + set allfiles [concat $allfiles $files] + } + } else { + set folders [glob -nocomplain -directory $item -type {d} -tail [file tail $item]] + set allfolders [concat $allfolders $folders] + set files [glob -nocomplain -directory [file dirname $item] -tail [file tail $item]] + set allfiles [concat $allfiles $files] + } + } + + + set sorted_folders [natsort::sort $allfolders {*}$args] + set sorted_files [natsort::sort $allfiles {*}$args] + + foreach fold $sorted_folders { + puts stdout $fold + } + foreach file $sorted_files { + puts stdout $file + } + + return "-- ok printed to stdout [llength $sorted_folders] folders and [llength $sorted_files] files --" + } + + package require argp + argp::registerArgs commandline_test { + { -showsplits boolean 0} + { -stacktrace boolean 0} + { -debug boolean 0} + { -winlike boolean 0} + { -db string ":memory:"} + { -collate string "nocase"} + { -algorithm string "sort"} + { -topchars string "\uFFFF"} + { -testlist string {10 1 30 3}} + } + argp::setArgsNeeded commandline_test {-stacktrace} + proc commandline_test {test args} { + variable testlist + puts stdout "commandline_test got $args" + argp::parseArgs opts + puts stdout "commandline_test got [array get opts]" + set args [check_flags -caller natsort_commandline \ + -return flagged|defaults \ + -defaults [list -db :memory: -collate nocase -testlist $testlist -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] \ + -values $args] + + if {[string tolower $test] in [list "1" "true"]} { + set test "sort" + } else { + if {![llength [info commands $test]]} { + error "test $test not found" + } + } + dict unset args -test + set stacktrace [dict get $args -stacktrace] + # dict unset args -stacktrace + + set argtestlist [dict get $args -testlist] + dict unset args -testlist + + + set debug [dict get $args -debug] + + set collate [dict get $args -collate] + set db [dict get $args -db] + set winlike [dict get $args -winlike] + set topchars [dict get $args -topchars] + + + puts stderr "|test>-----start natsort::$test--- input list size : [llength $argtestlist]" + #set resultlist [$test $argtestlist -db $db -collate $collate -topchars $topchars -winlike $winlike] + set resultlist [$test $argtestlist {*}$args] + foreach nm $resultlist { + puts stdout $nm + } + puts stdout "|test>-----end natsort::$test--- sorted list size: [llength $resultlist]" + return "test end" + } + proc commandline_runtests {runtests args} { + set argvals [check_flags -caller commandline_runtests \ + -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits "\uFFFF" -runtests 1] \ + -values $args] + + puts stderr "runtests args: $argvals" + + #set runtests [dict get $argvals -runtests] + dict unset argvals -runtests + dict unset argvals -algorithm + + puts stderr "runtests args: $argvals" + #exit 0 + + set test_prefix "::natsort::test_sort_" + + if {$runtests eq "1"} { + set runtests "*" + } + + + set testcommands [info commands ${test_prefix}${runtests}] + if {![llength $testcommands]} { + puts stderr "No test commands matched -runtests argument '$runtests'" + puts stderr "Use 1 to run all tests" + set alltests [info commands ${test_prefix}*] + puts stderr "Valid tests are:" + + set prefixlen [string length $test_prefix] + foreach t $alltests { + set shortname [string range $t $prefixlen end] + puts stderr "$t = -runtests $shortname" + } + + } else { + foreach cmd $testcommands { + puts stderr [string repeat - 40] + puts stderr "calling $cmd with args: '$argvals'" + puts stderr [string repeat - 40] + $cmd {*}$argvals + } + } + exit 0 + } + proc help {args} { + puts stdout "natsort::help got '$args'" + return "Help not implemented" + } + proc natsort_pipe {args} { + #PIPELINE to take input list on stdin and write sorted list to stdout + #strip - from arglist + #set args [check_flags -caller natsort_pipeline \ + # -return all \ + # -defaults [list -db :memory: -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] \ + # -values $args] + + + set debug [dict get $args -debug] + if {$debug} { + puts stderr "|debug> natsort_pipe got args:'$args'" + } + set algorithm [dict get $args -algorithm] + dict unset args -algorithm + + set proclist [info commands ::natsort::sort*] + set algos [list] + foreach p $proclist { + lappend algos [namespace tail $p] + } + if {$algorithm ni [list {*}$proclist {*}$algos]} { + do_error "valid sort mechanisms: $algos" 2 + } + + + set input_list [list] + while {![eof stdin]} { + if {[gets stdin line] > 0} { + lappend input_list $line + } else { + if {[eof stdin]} { + + } else { + after 10 + } + } + } + + if {$debug} { + puts stderr "|debug> received [llength $input_list] list elements" + } + + set resultlist [$algorithm $input_list {*}$args] + if {$debug} { + puts stderr "|debug> returning [llength $resultlist] list elements" + } + foreach r $resultlist { + puts stdout $r + } + #exit 0 + + } + if {($is_called_directly)} { + set cmdprocessors { + {helpfinal {match "^help$" dispatch natsort::help}} + {helpfinal {sub -topic default "NONE"}} + } + #set args [check_flags \ + # -caller test1 \ + # -debugargs 2 \ + # -return arglist \ + # -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] \ + # -required {none} \ + # -extras {all} \ + # -commandprocessors $cmdprocessors \ + # -values $::argv ] + interp alias {} do_filter {} ::flagfilter::check_flags + + #mashopts are generally single-letter opts that can be run together e.g -l -d as -ld + set cmdprocessors { + {helpcmd {match "^help$" dispatch natsort::help singleopts {-v}}} + {helpcmd {sub -operand default \uFFFF singleopts {-l}}} + {lscmd {match "^ls$" dispatch natsort::commandline_ls dispatchtype tcl dispatchglobal 1 mashopts {-l -a} singleopts {-l -a} pairopts {} longopts {--color=always}}} + {lscmd {sub dir default "\uFFFF"}} + {lscmd {sub dir2 default "\uFFFF"}} + {lscmd {sub dir3 default "\uFFFF"}} + {lscmd {sub dir4 default "\uFFFF"}} + {lscmd {sub dir5 default "\uFFFF"}} + {lscmd {sub dir6 default "\uFFFF"}} + {runtests {match "^-tests$" dispatch natsort::commandline_runtests singleopts {-l}}} + {runtests {sub testname default "1" singleopts {-l}}} + {pipecmd {match "^-$" dispatch natsort::natsort_pipe dispatchtype tcl}} + } + set arglist [do_filter \ + -debugargs 0 \ + -debugargsonerror 2 \ + -caller cline_dispatch1 \ + -return all \ + -soloflags {-v -x} \ + -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 ] \ + -required {all} \ + -extras {all} \ + -commandprocessors $cmdprocessors \ + -values $::argv ] + + + #mashopts are generally single-letter opts that can be run together e.g -l -d as -ld + set cmdprocessors { + {testcmd {match "^test$" dispatch natsort::commandline_test singleopts {-l}}} + {testcmd {sub testname default "1" singleopts {-l}}} + } + set arglist [check_flags \ + -debugargs 0 \ + -caller cline_dispatch2 \ + -return all \ + -soloflags {-v -l} \ + -defaults [list -collate nocase -algorithm sort -testlist "1 2 3 10" -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 ] \ + -required {all} \ + -extras {all} \ + -commandprocessors $cmdprocessors \ + -values $::argv ] + + + + + #set cmdprocessors [list] + #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors $cmdprocessors -values $::argv ] + + #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors {-cmd {-cmd -cmdarg1 -default "."} {-cmd -cmdarg2 -default j}} -values $::argv ] + #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors {{-cmd -default help} {-cmd -cmdarg1 -default "."} {-cmd -cmdarg2 -default j}} -values $::argv ] + #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors {ls {ls lsdir -default "\uFFFF"}} -values $::argv ] + + exit 0 + + if {$::argc} { + + } + } +} + + +package provide natsort [namespace eval natsort { + variable version + set version 0.1.1.5 +}] + + diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/oolib-0.1.tm b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/oolib-0.1.tm new file mode 100644 index 00000000..9cf1ca07 --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/oolib-0.1.tm @@ -0,0 +1,195 @@ +#JMN - api should be kept in sync with package patternlib where possible +# +package provide oolib [namespace eval oolib { + variable version + set version 0.1 +}] + +namespace eval oolib { + oo::class create collection { + variable o_data ;#dict + variable o_alias + constructor {} { + set o_data [dict create] + } + method info {} { + return [dict info $o_data] + } + method count {} { + return [dict size $o_data] + } + method isEmpty {} { + expr {[dict size $o_data] == 0} + } + method names {{globOrIdx {}}} { + if {[llength $globOrIdx]} { + if {[string is integer -strict $globOrIdx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + if {[catch {lindex [dict keys $o_data] $idx} result]} { + error "[self object] no such index : '$idx'" + } else { + return $result + } + } else { + #glob + return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] + } + } else { + return [dict keys $o_data] + } + } + #like names but without globbing + method keys {} { + dict keys $o_data + } + method key {{posn 0}} { + if {$posn < 0} { + set posn "end-[expr {abs($posn + 1)}]" + } + if {[catch {lindex [dict keys $o_data] $posn} result]} { + error "[self object] no such index : '$posn'" + } else { + return $result + } + } + method hasKey {key} { + dict exists $o_data $key + } + method get {} { + return $o_data + } + method items {} { + return [dict values $o_data] + } + method item {key} { + if {[string is integer -strict $key]} { + if {$key > 0} { + set valposn [expr {(2*$key) +1}] + return [lindex $o_data $valposn] + } else { + set key "end-[expr {abs($key + 1)}]" + return [lindex [dict keys $o_data] $key] + } + } + if {[dict exists $o_data $key]} { + return [dict get $o_data $key] + } + } + #inverse lookup + method itemKeys {value} { + set value_indices [lsearch -all [dict values $o_data] $value] + set keylist [list] + foreach i $value_indices { + set idx [expr {(($i + 1) *2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } + method search {value args} { + set matches [lsearch {*}$args [dict values $o_data] $value] + if {"-inline" in $args} { + return $matches + } else { + set keylist [list] + foreach i $matches { + set idx [expr {(($i + 1) *2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } + } + #review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? + method alias {newAlias existingKeyOrAlias} { + if {[string is integer -strict $newAlias]} { + error "[self object] collection key alias cannot be integer" + } + if {[string length $existingKeyOrAlias]} { + set o_alias($newAlias) $existingKeyOrAlias + } else { + unset o_alias($newAlias) + } + } + method aliases {{key ""}} { + if {[string length $key]} { + set result [list] + foreach {n v} [array get o_alias] { + if {$v eq $key} { + lappend result $n $v + } + } + return $result + } else { + return [array get o_alias] + } + } + #if the supplied index is an alias, return the underlying key; else return the index supplied. + method realKey {idx} { + if {[catch {set o_alias($idx)} key]} { + return $idx + } else { + return $key + } + } + method add {value key} { + if {[string is integer -strict $key]} { + error "[self object] collection key must not be an integer. Use another structure if integer keys required" + } + if {[dict exists $o_data $key]} { + error "[self object] col_processors object error: key '$key' already exists in collection" + } + dict set o_data $key $value + return [expr {[dict size $o_data] - 1}] ;#return index of item + } + method remove {idx {endRange ""}} { + if {[string length $endRange]} { + error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" + } + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx+1)}]" + } + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + if {$posn < 0} { + error "[self object] no such index: '$idx' in this collection" + } + } + dict unset o_data $key + return + } + method clear {} { + set o_data [dict create] + return + } + method reverse {} { + set dictnew [dict create] + foreach k [lreverse [dict keys $o_data]] { + dict set dictnew $k [dict get $o_data $k] + } + set o_data $dictnew + return + } + #review - cmd as list vs cmd as script? + method map {cmd} { + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list {*}$cmd $v]] + } + return $seed + } + method objectmap {cmd} { + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list $v {*}$cmd]] + } + return $seed + } + } + +} + diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/overtype-1.5.0.tm b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/overtype-1.5.0.tm new file mode 100644 index 00000000..f4e466f3 --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/overtype-1.5.0.tm @@ -0,0 +1,1039 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) Julian Noble 2003-2023 +# +# @@ Meta Begin +# Application overtype 1.5.0 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz +package require textutil +package require punk::ansi ;#required to detect, split, strip and calculate lengths +package require punk::char ;#box drawing - and also unicode character width determination for proper layout of text with double-column-width chars + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#Julian Noble - 2003 +#Released under standard 'BSD license' conditions. +# +#todo - ellipsis truncation indicator for center,right + +#v1.4 2023-07 - naive ansi color handling - todo - fix string range +# - need to extract and replace ansi codes? + +namespace eval overtype { + namespace export * + variable default_ellipsis_horizontal "..." ;#fallback + variable default_ellipsis_vertical "..." + namespace eval priv { + proc _init {} { + upvar ::overtype::default_ellipsis_horizontal e_h + upvar ::overtype::default_ellipsis_vertical e_v + set e_h [format %c 0x2026] ;#Unicode Horizontal Ellipsis + set e_v [format %c 0x22EE] + #The unicode ellipsis looks more natural than triple-dash which is centred vertically whereas ellipsis is at floorline of text + #Also - unicode ellipsis has semantic meaning that other processors can interpret + #unicode does also provide a midline horizontal ellipsis 0x22EF + + #set e [format %c 0x2504] ;#punk::char::charshort boxd_ltdshhz - Box Drawings Light Triple Dash Horizontal + #if {![catch {package require punk::char}]} { + # set e [punk::char::charshort boxd_ltdshhz] + #} + } + } + priv::_init +} +proc overtype::about {} { + return "Simple text formatting. Author JMN. BSD-License" +} + +namespace eval overtype { + variable escape_terminals + #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). + dict set escape_terminals CSI [list @ \\ ^ _ ` | ~ a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z "\{" "\}"] + #dict set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic + dict set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals + + #self-contained 2 byte ansi escape sequences - review more? + variable ansi_2byte_codes_dict + set ansi_2byte_codes_dict [dict create\ + "reset_terminal" "\u001bc"\ + "save_cursor_posn" "\u001b7"\ + "restore_cursor_posn" "\u001b8"\ + "cursor_up_one" "\u001bM"\ + "NEL - Next Line" "\u001bE"\ + "IND - Down one line" "\u001bD"\ + "HTS - Set Tab Stop" "\u001bH"\ + ] + + #debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway. + # "PM - Privacy Message" "\u001b^somethinghidden\033\\"\ +} + + +#candidate for zig/c implementation? +proc overtype::stripansi {text} { + variable escape_terminals ;#dict + variable ansi_2byte_codes_dict + #important that we don't spend too much time on this for plain text that doesn't contain any escapes anyway + if {[string first \033 $text] <0 && [string first \009c $text] <0} { + #\033 same as \x1b + return $text + } + + set text [convert_g0 $text] + + #we process char by char - line-endings whether \r\n or \n should be processed as per any other character. + #line endings can theoretically occur within an ansi escape sequence (review e.g title?) + set inputlist [split $text ""] + set outputlist [list] + + set 2bytecodes [dict values $ansi_2byte_codes_dict] + + set in_escapesequence 0 + #assumption - undertext already 'rendered' - ie no backspaces or carriagereturns or other cursor movement controls + set i 0 + foreach u $inputlist { + set v [lindex $inputlist $i+1] + set uv ${u}${v} + if {$in_escapesequence eq "2b"} { + #2nd byte - done. + set in_escapesequence 0 + } elseif {$in_escapesequence != 0} { + set escseq [dict get $escape_terminals $in_escapesequence] + if {$u in $escseq} { + set in_escapesequence 0 + } elseif {$uv in $escseq} { + set in_escapseequence 2b ;#flag next byte as last in sequence + } + } else { + #handle both 7-bit and 8-bit CSI and OSC + if {[regexp {^(?:\033\[|\u009b)} $uv]} { + set in_escapesequence CSI + } elseif {[regexp {^(?:\033\]|\u009c)} $uv]} { + set in_escapesequence OSC + } elseif {$uv in $2bytecodes} { + #self-contained e.g terminal reset - don't pass through. + set in_escapesequence 2b + } else { + lappend outputlist $u + } + } + incr i + } + return [join $outputlist ""] +} + +#review +#todo - map other chars to unicode equivs +proc overtype::convert_g0 {text} { + #using not \033 inside to stop greediness - review how does it compare to ".*?" + set re {\033\(0[^\033]*\033\(B} + set re2 {\033\(0(.*)\033\(B} ;#capturing + set parts [ta::_perlish_split $re $text] + set out "" + foreach {pt g} $parts { + append out $pt + if {$g ne ""} { + #puts --$g-- + #box sample + #lqk + #x x + #mqj + #m = boxd_lur + #set map [list l \u250f k \u2513] ;#heavy + set map [list l \u250c q \u2500 k \u2510 x \u2502 m \u2514 j \u2518] ;#light + + regexp $re2 $g _match contents + append out [string map $map $contents] + } + } + return $out +} + +#todo - convert esc(0 graphics sequences to single char unicode equivalents e.g box drawing set +# esc) ?? +proc overtype::stripansi_gx {text} { + #e.g "\033(0" - select VT100 graphics for character set G0 + #e.g "\033(B" - reset + #e.g "\033)0" - select VT100 graphics for character set G1 + #e.g "\033)X" - where X is any char other than 0 to reset ?? + return [convert_g0 $text] +} + + +#This shouldn't be called on text containing ansi codes! +proc overtype::strip_nonprinting_ascii {str} { + #review - some single-byte 'control' chars have visual representations e.g ETX as heart + #It is currently used for screen display width calculations + #equivalent for various unicode combining chars etc? + set map [list\ + \007 ""\ + [format %c 0] ""\ + [format %c 0x7f] ""\ + ] + return [string map $map $str] +} + +#length of text for printing characters only +#review - unicode and other non-printing chars and combining sequences? +#certain unicode chars are full-width (single char 2 columns wide) e.g see "Halfwdith and fullwidth forms" and ascii_fuillwidth blocks in punk::char::charset_names +#review - is there an existing library or better method? print to a terminal and query cursor position? +#Note this length calculation is only suitable for lines being appended to other strings if the line is pre-processed to account for backspace and carriage returns first +#If the raw line is appended to another string without such processing - the backspaces & carriage returns can affect data prior to the start of the string. +proc overtype::printing_length {line} { + if {[string first \n $line] >= 0} { + error "line_print_length must not contain newline characters" + } + + #review - + set line [stripansi $line] + + set line [strip_nonprinting_ascii $line] ;#only strip nonprinting after stripansi - some like BEL are part of ansi + #backspace 0x08 only erases* printing characters anyway - so presumably order of processing doesn't matter + #(* more correctly - moves cursor back) + #backspace will not move beyond a preceding newline - but we have disallowed newlines for this function already + #leading backspaces will eat into any string (even prompt in non-standard tclsh shell) that is prepended to the line + # - but for the purposes of overtype we wouldn't want that - so we strip it here in the length calculation and should strip leading backspaces in the actual data concatenation operations too. + #curiously - a backspace sequence at the end of a string also doesn't reduce the printing width - so we can also strip from RHS + + #Note that backspace following a \t will only shorten the string by one (ie it doesn't move back the whole tab width like it does interactively in the terminal) + #for this reason - it would seem best to normalize the tabs to spaces prior to performing the backspace calculation - otherwise we won't account for the 'short' tabs it effectivley produces + #normalize tabs to an appropriate* width + #*todo - handle terminal/context where tabwidth != the default 8 spaces + set line [textutil::tabify::untabify2 $line] + + set bs [format %c 0x08] + #set line [string map [list "\r${bs}" "\r"] $line] ;#backsp following a \r will have no effect + set line [string trim $line $bs] + set n 0 + + set chars [split $line ""] + #build an output + set idx 0 + set outchars [list] + set outsizes [list] + foreach c $chars { + if {$c eq $bs} { + if {$idx > 0} { + incr idx -1 + } + } elseif {$c eq "\r"} { + set idx 0 + } else { + priv::printing_length_addchar $idx $c + incr idx + } + } + set line2 [join $outchars ""] + return [punk::char::string_width $line2] +} + +proc overtype::string_columns {text} { + if {[punk::ansi::ta::detect $text]} { + error "error string_columns is for calculating character length of string - ansi codes must be stripped/rendered first e.g with overtype::stripansi. Alternatively try overtype::printing_length" + } + return [punk::char::string_width $text] +} + +namespace eval overtype::priv { + proc printing_length_addchar {i c} { + upvar outchars outc + upvar outsizes outs + set nxt [llength $outc] + if {$i < $nxt} { + lset outc $i $c + } else { + lappend outc $c + } + } +} + +#string range should generally be avoided for both undertext and overtext which contain ansi escapes and other cursor affecting chars such as \b and \r +proc overtype::left {args} { + # @c overtype starting at left (overstrike) + # @c can/should we use something like this?: 'format "%-*s" $len $overtext + variable default_ellipsis_horizontal + + if {[llength $args] < 2} { + error {usage: ?-transparent [0|1]? ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} + } + lassign [lrange $args end-1 end] underblock overblock + set defaults [dict create\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -overflow 0\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + ] + set known_opts [dict keys $defaults] + set argsflags [lrange $args 0 end-2] + dict for {k v} $argsflags { + if {$k ni $known_opts} { + error "overtype::left unknown option '$k'. Known options: $known_opts" + } + } + set opts [dict merge $defaults $argsflags] + # -- --- --- --- --- --- + set opt_transparent [dict get $opts -transparent] + set opt_ellipsistext [dict get $opts -ellipsistext] + set opt_exposed1 [dict get $opts -exposed1] + set opt_exposed2 [dict get $opts -exposed2] + # -- --- --- --- --- --- + + set norm [list \r\n \n] + set underblock [string map $norm $underblock] + set overblock [string map $norm $overblock] + + set underlines [split $underblock \n] + set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {printing_length $v}]] + set overlines [split $overblock \n] + + set outputlines [list] + foreach undertext $underlines overtext $overlines { + set undertext_printlen [printing_length $undertext] + set overlen [printing_length $overtext] + set diff [expr {$overlen - $colwidth}] + + #review + #append overtext "\033\[0m" + + if {$diff > 0} { + #background line is narrower + set rendered [renderline -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow [dict get $opts -overflow] $undertext $overtext] + if {![dict get $opts -overflow]} { + #set overtext [string range $overtext 0 $colwidth-1] ;#string range won't be correct e.g if contains ansi codes or leading \r or \b etc + if {[dict get $opts -ellipsis]} { + set rendered [overtype::right $rendered $opt_ellipsistext] + } + } + lappend outputlines $rendered + } else { + #we know overtext is shorter or equal + lappend outputlines [renderline -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + } + } + return [join $outputlines \n] + +} + +namespace eval overtype::piper { + proc overcentre {args} { + if {[llength $args] < 2} { + error {usage: ?-bias left|right? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} + } + lassign [lrange $args end-1 end] over under + set argsflags [lrange $args 0 end-2] + tailcall overtype::centre {*}$argsflags $under $over + } + proc overleft {args} { + if {[llength $args] < 2} { + error {usage: ?-start ? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} + } + lassign [lrange $args end-1 end] over under + set argsflags [lrange $args 0 end-2] + tailcall overtype::left {*}$argsflags $under $over + } +} +#todo - left-right ellipsis ? +proc overtype::centre {args} { + variable default_ellipsis_horizontal + if {[llength $args] < 2} { + error {usage: ?-transparent [0|1]? ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} + } + + foreach {underblock overblock} [lrange $args end-1 end] break + + set defaults [dict create\ + -bias left\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -overflow 0\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + ] + set known_opts [dict keys $defaults] + set argsflags [lrange $args 0 end-2] + dict for {k v} $argsflags { + if {$k ni $known_opts} { + error "overtype::centre unknown option '$k'. Known options: $known_opts" + } + } + set opts [dict merge $defaults $argsflags] + # -- --- --- --- --- --- + set opt_transparent [dict get $opts -transparent] + set opt_ellipsistext [dict get $opts -ellipsistext] + set opt_exposed1 [dict get $opts -exposed1] + set opt_exposed2 [dict get $opts -exposed2] + # -- --- --- --- --- --- + + + set norm [list \r\n \n] + set underblock [string map $norm $underblock] + set overblock [string map $norm $overblock] + + set underlines [split $underblock \n] + set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {printing_length $v}]] + set overlines [split $overblock \n] + + set outputlines [list] + foreach undertext $underlines overtext $overlines { + set olen [printing_length $overtext] + set ulen [printing_length $undertext] + if {$ulen < $colwidth} { + set udiff [expr {$colwidth - $ulen}] + set undertext "$undertext[string repeat { } $udiff]" + } + #review + append overtext "\033\[0m" + + set diff [expr {$colwidth - $olen}] + if {$diff > 0} { + #background block is wider + set half [expr {round(int($diff / 2))}] + if {[string match right [dict get $opts -bias]]} { + if {[expr {2 * $half}] < $diff} { + incr half + } + } + + set rhs [expr {$diff - $half - 1}] + set lhs [expr {$half - 1}] + set rhsoffset [expr {$rhs +1}] + if 0 { + set a [string range $undertext 0 $lhs] + set background [string range $undertext $lhs+1 end-$rhsoffset] + set b [renderline -transparent $opt_transparent $background $overtext] + set c [string range $undertext end-$rhs end] + lappend outputlines $a$b$c + } + lappend outputlines [renderline -start $lhs -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + + } else { + #overlay wider or equal + set rendered [renderline -transparent $opt_transparent -overflow [dict get $opts -overflow] $undertext $overtext] + if {$diff < 0} { + #overlay is wider - trim if overflow not specified in opts + if {![dict get $opts -overflow]} { + #lappend outputlines [string range $overtext 0 [expr {$colwidth - 1}]] + #set overtext [string range $overtext 0 $colwidth-1 ] + if {[dict get $opts -ellipsis]} { + set rendered [overtype::right $rendered $opt_ellipsistext] + } + } + } else { + #widths match + } + lappend outputlines $rendered + #lappend outputlines [renderline -transparent $opt_transparent $undertext $overtext] + } + } + return [join $outputlines \n] +} + +proc overtype::right {args} { + variable default_ellipsis_horizontal + # @d !todo - implement overflow, length checks etc + + if {[llength $args] < 2} { + error {usage: ?-overflow [1|0]? undertext overtext} + } + foreach {underblock overblock} [lrange $args end-1 end] break + + set defaults [dict create\ + -bias left\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -overflow 0\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + ] + set known_opts [dict keys $defaults] + set argsflags [lrange $args 0 end-2] + dict for {k v} $argsflags { + if {$k ni $known_opts} { + error "overtype::centre unknown option '$k'. Known options: $known_opts" + } + } + set opts [dict merge $defaults $argsflags] + # -- --- --- --- --- --- + set opt_transparent [dict get $opts -transparent] + set opt_ellipsis [dict get $opts -ellipsis] + set opt_ellipsistext [dict get $opts -ellipsistext] + set opt_overflow [dict get $opts -overflow] + set opt_exposed1 [dict get $opts -exposed1] + set opt_exposed2 [dict get $opts -exposed2] + # -- --- --- --- --- --- + + set norm [list \r\n \n] + set underblock [string map $norm $underblock] + set overblock [string map $norm $overblock] + + set underlines [split $underblock \n] + set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {printing_length $v}]] + set overlines [split $overblock \n] + + set outputlines [list] + foreach undertext $underlines overtext $overlines { + set olen [printing_length $overtext] + set ulen [printing_length $undertext] + if {$ulen < $colwidth} { + set udiff [expr {$colwidth - $ulen}] + set undertext "$undertext[string repeat { } $udiff]" + } + #review + #append overtext "\033\[0m" + + set overflowlength [expr {$olen - $colwidth}] + if {$overflowlength > 0} { + #overtext wider than undertext column + set rendered [renderline -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow $opt_overflow -start 0 $undertext $overtext] + if {!$opt_overflow} { + if {$opt_ellipsis} { + set rendered [overtype::right $rendered $opt_ellipsistext] + } + } + lappend outputlines $rendered + } else { + #lappend outputlines [string range $undertext 0 end-$olen]$overtext + lappend outputlines [renderline -transparent $opt_transparent -start [expr {$colwidth - $olen}] $undertext $overtext] + } + } + + return [join $outputlines \n] +} + +# -- --- --- --- --- --- --- --- --- --- --- +proc overtype::transparentline {args} { + foreach {under over} [lrange $args end-1 end] break + set argsflags [lrange $args 0 end-2] + set defaults [dict create\ + -transparent 1\ + -exposed 1 " "\ + -exposed 2 " "\ + ] + set newargs [dict merge $defaults $argsflags] + tailcall overtype::renderline {*}$newargs $under $over +} +#renderline may not make sense as it is in the long run for blocks of text - but is handy in the single-line-handling form anyway. +# We are trying to handle ansi codes in a block of text which is acting like a mini-terminal in some sense. +#We can process standard cursor moves such as \b \r - but no way to respond to other cursor movements e.g moving to other lines. +# +namespace eval overtype::piper { + proc renderline {args} { + if {[llength $args] < 2} { + error {usage: ?-start ? ?-transparent [0|1|]? ?-overflow [1|0]? overtext pipelinedata} + } + foreach {over under} [lrange $args end-1 end] break + set argsflags [lrange $args 0 end-2] + tailcall overtype::renderline {*}$argsflags $under $over + } +} +interp alias "" piper_renderline "" overtype::piper::renderline + +#-returnextra to enable returning of overflow and length +# todo - use ta::detect to short-circuit processing and do simple string calcs as an optimisation? +#review - DECSWL/DECDWL double width line codes - very difficult/impossible to align and compose with other elements +#todo - review transparency issues with single/double width characters! +proc overtype::renderline {args} { + if {[llength $args] < 2} { + error {usage: ?-start ? ?-transparent [0|1|]? ?-overflow [1|0]? undertext overtext} + } + lassign [lrange $args end-1 end] under over + if {[string first \n $under] >=0 || [string first \n $over] >= 0} { + error "overtype::renderline not allowed to contain newlines" + } + set defaults [dict create\ + -overflow 0\ + -transparent 0\ + -start 0\ + -returnextra 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + ] + #exposed1 and exposed2 for first and second col of underying 2wide char which is truncated by transparency or overflow + + set known_opts [dict keys $defaults] + set argsflags [lrange $args 0 end-2] + dict for {k v} $argsflags { + if {$k ni $known_opts} { + error "overtype::renderline unknown option '$k'. Known options: $known_opts" + } + } + set opts [dict merge $defaults $argsflags] + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_overflow [dict get $opts -overflow] + set opt_colstart [dict get $opts -start] + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_transparent [dict get $opts -transparent] + if {$opt_transparent eq "0"} { + set do_transparency 0 + } else { + set do_transparency 1 + if {$opt_transparent eq "1"} { + set opt_transparent {[\s]} + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_returnextra [dict get $opts -returnextra] + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_exposed1 [dict get $opts -exposed1] + set opt_exposed2 [dict get $opts -exposed2] + # -- --- --- --- --- --- --- --- --- --- --- --- + + #----- + # + if {[string first \t $under] >= 0} { + #set under [textutil::tabify::untabify2 $under] + set under [textutil::tabify::untabifyLine $under 8] ;#8 is default for untabify2 - review + } + set overdata $over + if {[string first \t $over] >= 0} { + #set overdata [textutil::tabify::untabify2 $over] + set overdata [textutil::tabify::untabifyLine $over 8] + } + #------- + + #ta_detect ansi and do simpler processing? + + + # -- --- --- --- --- --- --- --- + set undermap [punk::ansi::ta::split_codes_single $under] + set understacks [dict create] + + set i_u -1 + set i_o 0 + set out [list] + set u_codestack [list] + set pt_underchars "" ;#for string_columns length calculation for overflow 0 truncation + set remainder [list] ;#for returnextra + foreach {pt code} $undermap { + #pt = plain text + append pt_underchars $pt + foreach ch [split $pt ""] { + set width [punk::char::string_width $ch] + incr i_u + dict set understacks $i_u $u_codestack + lappend out $ch + if {$width > 1} { + #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) + incr i_u + dict set understacks $i_u $u_codestack + lappend out "" + } + } + #underlay should already have been rendered and not have non-sgr codes - but let's check for and not stack them if other codes are here + if {[priv::is_sgr $code]} { + if {[priv::has_sgr_leadingreset $code]} { + set u_codestack [list $code] + } else { + lappend u_codestack $code + } + } + #consider also other codes that should be stacked..? + } + #trailing codes in effect for underlay + if {[llength $undermap]} { + dict set understacks [expr {$i_u + 1}] $u_codestack + } + + + # -- --- --- --- --- --- --- --- + #### + #if opt_colstart - we need to build a space (or any singlewidth char really) padding on the left of the right number of columns. + #this will be processed as transparent - and handle doublewidth underlay characters appropriately + set startpad [string repeat " " $opt_colstart] + append startpad $overdata ;#overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency + set overmap [punk::ansi::ta::split_codes_single $startpad] + #### + + + + set overstacks [dict create] + set o_codestack [list] + set pt_overchars "" + foreach {pt code} $overmap { + append pt_overchars $pt + foreach ch [split $pt ""] { + dict set overstacks $i_o $o_codestack + incr i_o + } + if {[priv::is_sgr $code]} { + #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc + if {[priv::has_sgr_leadingreset $code]} { + #m code which has sgr reset at start - no need to replay prior sgr codes + set o_codestack [list $code] + } else { + lappend o_codestack $code + } + } + } + # -- --- --- --- --- --- --- --- + + + + + set bs [format %c 0x08] + set idx 0 ;# line index (cursor - 1) + set idx_over -1 + foreach {pt code} $overmap { + set ptchars [split $pt ""] ;#for lookahead + #emit plaintext chars first using existing SGR codes from under/over stack as appropriate + #then check if the following code is a cursor movement within the line and adjust index if so + foreach ch $ptchars { + incr idx_over + if {$ch eq "\r"} { + set idx $opt_colstart + } elseif {$ch eq "\b"} { + #review - backspace effect on double-width chars + if {$idx > $opt_colstart} { + incr idx -1 + } + } elseif {($idx < $opt_colstart)} { + incr idx + } elseif {($do_transparency && [regexp $opt_transparent $ch])} { + #pre opt_colstart is effectively transparent (we have applied padding of required number of columns to left of overlay) + set owidth [punk::char::string_width $ch] + if {$idx > [llength $out]-1} { + lappend out " " + dict set understacks $idx [list] ;#review - use idx-1 codestack? + incr idx + } else { + set uwidth [punk::char::string_width [lindex $out $idx]] + if {[lindex $out $idx] eq ""} { + #2nd col of 2-wide char in underlay + incr idx + } elseif {$uwidth == 0} { + #e.g combining diacritic + incr idx + } elseif {$uwidth == 1} { + incr idx + if {$owidth > 1} { + incr idx + } + } elseif {$uwidth > 1} { + if {[punk::char::string_width $ch] == 1} { + #normal singlewide transparency + set next_pt_overchar [string index $pt_overchars $idx_over+1] ;#lookahead of next plain-text char in overlay + if {$next_pt_overchar eq ""} { + #special-case trailing transparent - no next_pt_overchar + incr idx + } else { + if {[regexp $opt_transparent $next_pt_overchar]} { + incr idx + } else { + #next overlay char is not transparent.. first-half of underlying 2wide char is exposed + priv::render_addchar $idx $opt_exposed1 [dict get $overstacks $idx_over] + incr idx + } + } + } else { + #2wide transparency over 2wide in underlay + incr idx + } + } + } + } else { + #non-transparent char in overlay + set owidth [punk::char::string_width $ch] + set uwidth [punk::char::string_width [lindex $out $idx]] + if {[lindex $out $idx] eq ""} { + #2nd col of 2wide char in underlay + priv::render_addchar $idx $ch [dict get $overstacks $idx_over] + incr idx + } elseif {$uwidth == 0} { + #e.g combining diacritic - increment before over char REVIEW + #arguably the previous overchar should have done this - ie lookahead for combiners? + priv::render_addchar $idx "" [dict get $overstacks $idx_over] + incr idx + priv::render_addchar $idx $ch [dict get $overstacks $idx_over] + incr idx + + } elseif {$uwidth == 1} { + if {$owidth == 1} { + priv::render_addchar $idx $ch [dict get $overstacks $idx_over] + incr idx + } else { + priv::render_addchar $idx $ch [dict get $overstacks $idx_over] + incr idx + priv::render_addchar $idx "" [dict get $overstacks $idx_over] + } + } elseif {$uwidth > 1} { + if {$owidth == 1} { + priv::render_addchar $idx $ch [dict get $overstacks $idx_over] + incr idx + priv::render_addchar $idx $opt_exposed2 [dict get $overstacks $idx_over] + #don't incr idx - we are just putting a broken-indication in the underlay - which may get overwritten by next overlay char + } else { + #2wide over 2wide + priv::render_addchar $idx $ch [dict get $overstacks $idx_over] + incr idx + } + } + } + } + #check following code + if {![priv::is_sgr $code]} { + + } + } + + if {$opt_overflow == 0} { + #need to truncate to the width of the original undertext + #review - string_width vs printing_length here. undertext requirement to be already rendered therefore punk::char::string_width ok? + set num_under_columns [punk::char::string_width $pt_underchars] ;#plaintext underchars + } + + #coalesce and replay codestacks for out char list + set outstring "" + set remstring "" ;#remainder after overflow point reached + set i 0 + set cstack [list] + set prevstack [list] + set out_rawchars ""; #for overflow counting + set output_to "outstring" ;#var in effect depending on overflow + set in_overflow 0 ;#used to stop char-width scanning once in overflow + foreach ch $out { + append out_rawchars $ch + if {$opt_overflow == 0 && !$in_overflow} { + if {[set nextvisualwidth [punk::char::string_width $out_rawchars]] < $num_under_columns} { + } else { + #todo - check if we overflowed with a double-width char ? + #store visualwidth which may be short + set in_overflow 1 + } + } + set cstack [dict get $understacks $i] + if {$cstack ne $prevstack} { + if {[llength $prevstack]} { + append $output_to \033\[m + } + foreach code $cstack { + append $output_to $code + } + } + append $output_to $ch + set prevstack $cstack + incr i + if {$in_overflow} { + set output_to "remstring" + } + } + if {[dict size $understacks] > 0} { + append $output_to [join [dict get $understacks [expr {[dict size $understacks]-1}]] ""] ;#tail codes + } + if {[string length $remstring]} { + #puts stderr "remainder:$remstring" + } + #pdict $understacks + if {$opt_returnextra} { + return [list $outstring $visualwidth [string length $outstring] $remstring] + } else { + return $outstring + } + #return [join $out ""] +} +proc overtype::test_renderline {} { + set t \uFF5E ;#2-wide tilde + set u \uFF3F ;#2-wide underscore + set missing \uFFFD + return [list $t $u A${t}B] +} +namespace eval overtype::priv { + #todo - move to punk::ansi::codetype + proc is_sgr {code} { + #SGR (Select Graphic Rendition) - codes ending in 'm' - e.g colour/underline + #we will accept and pass through the less common colon separator (ITU Open Document Architecture) + #Terminals should generally ignore it if they don't use it + regexp {\033\[[0-9;:]*m$} $code + } + proc is_cursor_move_in_line {code} { + #review - what about CSI n : m H where row n happens to be current line? + regexp {\033\[[0-9]*(:?C|D|G)$} + } + #pure SGR reset + proc is_sgr_reset {code} { + #todo 8-bit csi + regexp {\033\[0*m$} $code + } + #whether this code has 0 (or equivalently empty) parameter (but may set others) + #if an SGR code as a reset in it - we don't need to carry forward any previous SGR codes + #it generally only makes sense for the reset to be the first entry - otherwise the code has ineffective portions + #However - detecting zero or empty parameter in other positions requires knowing all other codes that may allow zero or empty params. + #We will only look at initial parameter as this is the well-formed normal case. + #Review - consider normalizing sgr codes to remove other redundancies such as setting fg or bg color twice in same code + proc has_sgr_leadingreset {code} { + set params "" + regexp {\033\[(.*)m} $code _match params + set plist [split $params ";"] + if {[string trim [lindex $plist 0] 0] eq ""} { + #e.g \033\[m \033\[0\;...m \033\[0000...m + return 1 + } else { + return 0 + } + } + #has_sgr_reset - rather than support this - create an sgr normalize function that removes dead params and brings reset to front of param list + proc render_addchar {i c stack} { + upvar out o + upvar understacks ustacks + set nxt [llength $o] + if {$i < $nxt} { + lset o $i $c + } else { + lappend o $c + } + dict set ustacks $i $stack + } + +} + + +# -- --- --- --- --- --- --- --- --- --- --- +namespace eval overtype::ta { + namespace path ::overtype + #*based* on but not identical to: + #https://github.com/perlancar/perl-Text-ANSI-Util/blob/master/lib/Text/ANSI/BaseUtil.pm + + #handle both 7-bit and 8-bit csi + #review - does codepage affect this? e.g ebcdic has 8bit csi in different position + + #CSI + #variable re_csi_open {(?:\033\[|\u009b)[0-9;]+} ;#too specific - doesn't detect \033\[m + variable re_csi_open {(?:\033\[|\u009b])} + + #colour and style + variable re_csi_colour {(?:\033\[|\u009b)[0-9;]*m} ;#e.g \033\[31m \033\[m \033\[0m \033\[m0000m + #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). + variable re_csi_code {(?:\033\[|\u009b])[0-9;]*[a-zA-Z\\@^_|~`]} + + #OSC - termnate with BEL (\a \007) or ST (string terminator \033\\) + #variable re_esc_osc1 {(?:\033\]|\u009c).*\007} + #variable re_esc_osc2 {(?:\033\]|\u009c).*\033\\} + + #test - non-greedy + variable re_esc_osc1 {(?:\033\]|\u009c).*?\007} + variable re_esc_osc2 {(?:\033\]|\u009c).*?\033\\} + + variable re_ansi_detect "${re_csi_open}|${re_esc_osc1}|${re_esc_osc2}" + + #detect any ansi escapes + #review - only detect 'complete' codes - or just use the opening escapes for performance? + proc detect {text} { + variable re_ansi_detect + #variable re_csi_open + #variable re_esc_osc1 + #variable re_esc_osc2 + #todo - other escape sequences + #expr {[regexp $re_csi_open $text] || [regexp $re_esc_osc1 $text] || [regexp $re_esc_osc2 $text]} + expr {[regexp $re_ansi_detect $text]} + } + #not in perl ta + proc detect_csi {text} { + variable re_csi_colour + expr {[regexp $re_csi_colour $text]} + } + proc strip {text} { + tailcall stripansi $text + } + #note this is character length after stripping ansi codes - not the printing length + proc length {text} { + string length [overtype::stripansi $text] + } + #todo - handle newlines + #not in perl ta + proc printing_length {text} { + + } + + proc trunc {text width args} { + + } + + #not in perl ta + #returns just the plaintext portions in a list + proc split_at_codes {text} { + variable re_esc_osc1 + variable re_esc_osc2 + variable re_csi_code + textutil::splitx $text "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}" + } + + # -- --- --- --- --- --- + #Split $text to a list containing alternating ANSI color codes and text. + #ANSI color codes are always on the second element, fourth, and so on. + #(ie plaintext on odd list-indices ansi on even indices) + # Example: + #ta_split_codes "" # => "" + #ta_split_codes "a" # => "a" + #ta_split_codes "a\e[31m" # => {"a" "\e[31m"} + #ta_split_codes "\e[31ma" # => {"" "\e[31m" "a"} + #ta_split_codes "\e[31ma\e[0m" # => {"" "\e[31m" "a" "\e[0m"} + #ta_split_codes "\e[31ma\e[0mb" # => {"" "\e[31m" "a" "\e[0m", "b"} + #ta_split_codes "\e[31m\e[0mb" # => {"" "\e[31m\e[0m" "b"} + # + proc split_codes {text} { + variable re_esc_osc1 + variable re_esc_osc2 + variable re_csi_code + set re "(?:${re_csi_code}|${re_esc_osc1}|${re_esc_osc2})+" + return [_perlish_split $re $text] + } + #like split_codes - but each ansi-escape is split out separately (with empty string of plaintext between codes so odd/even plain ansi still holds) + proc split_codes_single {text} { + variable re_esc_osc1 + variable re_esc_osc2 + variable re_csi_code + set re "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}" + return [_perlish_split $re $text] + } + + #review - tcl greedy expressions may match multiple in one element + proc _perlish_split {re text} { + if {[string length $text] == 0} { + return {} + } + set list [list] + set start 0 + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + lappend list [string range $text $start $matchStart-1] [string range $text $matchStart $matchEnd] + set start [expr {$matchEnd+1}] + } + lappend list [string range $text $start end] + return $list + } + proc _ws_split {text} { + regexp -all -inline {(?:\S+)|(?:\s+)} $text + } + # -- --- --- --- --- --- + +} + +# -- --- --- --- --- --- --- --- --- --- --- +namespace eval overtype { + interp alias {} ::overtype::center {} ::overtype::centre +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide overtype [namespace eval overtype { + variable version + set version 1.5.0 +}] +return \ No newline at end of file diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/du-0.1.0.tm b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/du-0.1.0.tm new file mode 100644 index 00000000..ff7999fe --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/du-0.1.0.tm @@ -0,0 +1,1308 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application punk::du 0.1.0 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz +package require punk::mix::base + + +namespace eval punk::du { + variable has_twapi 0 +} +if {"windows" eq $::tcl_platform(platform)} { + package require zzzload + zzzload::pkg_require twapi + #if {[catch {package require twapi}]} { + # puts stderr "Warning: punk::du - unable to load twapi. Disk operations may be much slower on windows without the twapi package" + #} else { + # set punk::du::has_twapi 1 + #} + #package require punk::winpath +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::du { + + + proc dirlisting {folderpath args} { + set defaults [dict create\ + -glob *\ + ] + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_glob [dict get $opts -glob] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + if {[lib::pathcharacterlen $folderpath] == 0} { + set folderpath [pwd] + } elseif {[file pathtype $folderpath] ne "absolute"} { + #file normalize relativelly slow - avoid in inner loops + #set folderpath [file normalize $folderpath] + + } + #run whichever of du_dirlisting_twapi, du_dirlisting_generic, du_dirlisting_unix has been activated + set dirinfo [active::du_dirlisting $folderpath {*}$opts] + } + + + + #Note that unix du seems to do depth-first - which makese sense when piping.. as output can be emitted as we go rather than requiring sort at end. + #breadth-first with sort can be quite fast .. but memory usage can easily get out of control + proc du { args } { + variable has_twapi + package require struct::set + + + if 0 { + switch -exact [llength $args] { + 0 { + set dir . + set switch -k + } + 1 { + set dir $args + set switch -k + } + 2 { + set switch [lindex $args 0] + set dir [lindex $args 1] + } + default { + set msg "only one switch and one dir " + append msg "currently supported" + return -code error $msg + } + } + + set switch [string tolower $switch] + + set -b 1 + set -k 1024 + set -m [expr 1024*1024] + } + + + set opts $args + # flags in args are solos (or longopts --something=somethingelse) or sometimes pairopts + # we don't currently support mashopts (ie -xy vs separate -x -y) + + + #------------------------------------------------------- + # process any pairopts first and remove the pair + # (may also process some solo-opts) + + set opt_depth -1 + if {[set posn [lsearch $opts -d]] >= 0} { + set opt_depth [lindex $opts $posn+1] + set opts [lreplace $opts $posn $posn+1] + } + foreach o $opts { + if {[string match --max-depth=* $o]} { + set opt_depth [lindex [split $o =] 1] + if {![string is integer -strict $opt_depth]} { + error "--max-depth=n n must be an integer" + } + } + } + #------------------------------------------------------- + #only solos and longopts remain in the opts now + + + set lastarg [lindex $opts end] + if {[string length $lastarg] && (![string match -* $lastarg])} { + set dir $lastarg + set opts [lrange $opts 0 end-1] + } else { + set dir . + set opts $opts + } + foreach a $opts { + if {![string match -* $a]} { + error "unrecognized option '$a'" + } + } + + set -b 1 + set -k 1024 + set -m [expr 1024*1024] + set switch -k ;#default (same as unix) + set lc_opts [string tolower $opts] + + + + if {"-b" in $lc_opts} { + set switch -b + } elseif {"-k" in $lc_opts} { + set switch -k + } elseif {"-m" in $lc_opts} { + set switch -m + } + set opt_progress 0 + if {"--prog" in $lc_opts || "--progress" in $lc_opts} { + set opt_progress 1 + } + set opt_extra 0 + if {"--extra" in $lc_opts} { + set opt_extra 1 + } + set opt_vfs 0 + #This configures whether to enter a vfsmount point + #It will have no effect if cwd already with a vfs mount point - as then opt_vfs will be set to 1 automatically anyway. + if {"--vfs" in $lc_opts} { + set opt_vfs 1 + } + + + + set result [list] + + set dir_depths_remaining [list] + + set is_windows [expr {$::tcl_platform(platform) eq "windows"}] + set zero [expr {0}] + + # ## ### ### ### ### + # containerid and itemid + set folders [list] ;#we lookup string by index + lappend folders [file dirname $dir] + lappend folders $dir ;#itemindex 1 + # ## ### ### ### ### + if {![file isdirectory $dir]} { + lappend dir_depths_remaining [list $zero $zero [expr {1}] [lib::du_lit [file tail $dir]] [file size $dir]] + #set ary($dir,bytes) [file size $dir] + set leveldircount 0 + } else { + lappend dir_depths_remaining [list $zero $zero [expr {1}] [lib::du_lit [file tail $dir]] $zero] + set leveldircount 1 + } + set level [expr {0}] + set nextlevel [expr {1}] + #dir_depths list structure + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #0 1 2 3 4 5 + #i_depth i_containerid i_itemid i_item i_size i_index + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set i_depth [expr {0}] + set i_containerid [expr {1}] + set i_itemid [expr {2}] + set i_item [expr {3}] + set i_size [expr {4}] + set i_index [expr {5}] + + + set listlength [llength $dir_depths_remaining] + set diridx 0 + #this is a breadth-first algorithm + while {$leveldircount > 0} { + set leveldirs 0 + set levelfiles 0 + for {set i $diridx} {$i < $listlength} {incr i} { + #lassign [lindex $dir_depths_remaining $i] _d containeridx folderidx itm bytecount + set folderidx [lindex $dir_depths_remaining $i $i_itemid] + set folderpath [lindex $folders $folderidx] + #puts stderr ->$folderpath + #if {$i >= 20} { + #return + #} + + #twapi supports gathering file sizes during directory contents traversal + #for dirlisting methods that return an empty list in filesizes whilst files has entries - we will need to populate it below + #e.g tcl glob based dirlisting doesn't support gathering file sizes at the same time + + set in_vfs 0 + if {[package provide vfs] ne ""} { + foreach vfsmount [vfs::filesystem info] { + if {[file pathtype $folderpath] ne "absolute"} { + set testpath [file normalize $folderpath] + } else { + set testpath $folderpath + } + + if {[punk::mix::base::lib::path_a_atorbelow_b $testpath $vfsmount]} { + set in_vfs 1 + #if already descended to or below a vfs mount point - set opt_vfs true + set opt_vfs 1 + break + } + } + } + + if {$in_vfs} { + set du_info [lib::du_dirlisting_tclvfs $folderpath] + } else { + #run the activated function (proc imported to active namespace and renamed) + set du_info [active::du_dirlisting $folderpath] + } + + + set dirs [dict get $du_info dirs] + set files [dict get $du_info files] + set filesizes [dict get $du_info filesizes] + set vfsmounts [dict get $du_info vfsmounts] + #puts "---> vfsmounts $vfsmounts " + if {$opt_vfs} { + foreach vm $vfsmounts { + #puts stderr "vm: $vm" + #check if vfs is mounted over a file or a dir + if {$vm in $files} { + puts stderr "vfs mounted over file $vm" + set mposn [lsearch $files $vm] + set files [lreplace $files $mposn $mposn] + if {[llength $filesizes]} { + set filesizes [lreplace $filesizes $mposn $mposn] + } + } + if {$vm ni $dirs} { + puts stderr "treating $vm as dir" + lappend dirs $vm + } + } + } + + + incr leveldirs [llength $dirs] + incr levelfiles [llength $files] + + #lappend dir_depths_remaining {*}[lmap d $dirs {::list $nextdepth [lib::du_lit $cont/$itm] $d $zero}] + #folderidx is parent index for new dirs + lappend dir_depths_remaining {*}[lib::du_new_eachdir $dirs $nextlevel $folderidx] + + #we don't need to sort files (unless we add an option such as -a to du (?)) + set bytecount [expr {0}] + + if {[llength $files] && ![llength $filesizes]} { + #listing mechanism didn't supply corresponding sizes + foreach filename $files { + #incr bytecount [file size [file join $folderpath $filename] + incr bytecount [file size $filename] + } + } else { + set filesizes [lsearch -all -inline -not $filesizes[unset filesizes] na] ;#only legal non-number is na + set bytecount [tcl::mathop::+ {*}$filesizes] + } + + + #we can safely assume initial count was zero + lset dir_depths_remaining $i $i_size $bytecount + #incr diridx + } + #puts stdout "level: $level dirs: $leveldirs" + if {$opt_extra} { + puts stdout "level: $level dircount: $leveldirs filecount: $levelfiles" + } + incr level ;#zero based + set nextlevel [expr {$level + 1}] + set leveldircount [expr {[llength $dir_depths_remaining] - $listlength }]; #current - previous - while loop terminates when zero + #puts "diridx: $diridx i: $i rem: [llength $dir_depths_remaining] listlenth:$listlength levldircount: $leveldircount" + set diridx $i + set listlength [llength $dir_depths_remaining] + } + #puts stdout ">>> loop done" + #flush stdout + #puts stdout $dir_depths_remaining + set dirs_as_encountered $dir_depths_remaining ;#index is in sync with 'folders' list + set dir_depths_longfirst $dirs_as_encountered + + #store the index before sorting + for {set i 0} {$i < [llength $dir_depths_remaining]} {incr i} { + lset dir_depths_longfirst $i $i_index $i + } + set dir_depths_longfirst [lsort -integer -index 0 -decreasing $dir_depths_longfirst[set dir_depths_longfirst {}]] + + #store main index in the reducing list + set dir_depths_remaining $dir_depths_longfirst + for {set i 0} {$i < [llength $dir_depths_remaining]} {incr i} { + #stored index at position 3 + lset dir_depths_remaining $i $i_index $i + } + + #index 3 + #dir_depths_remaining -> dir_depths_longfirst -> dirs_as_encountered + + #puts stdout "initial dir_depths_remaining: $dir_depths_remaining" + + + #summing performance is not terrible but significant on large tree - the real time is for large trees in the main loop above + #update - on really large trees the reverse is true especiallyl now that twapi fixed the original speed issues.. todo - rework/simplify below - review natsort + # + #TODO - reconsider sorting by depth.. lreverse dirs_as_encountered should work.. + if {[llength $dir_depths_longfirst] > 1} { + set i 0 + foreach dd $dir_depths_longfirst { + lassign $dd d parentidx folderidx item bytecount + #set nm $cont/$item + set nm [lindex $folders $folderidx] + set dnext [expr {$d +1}] + set nextdepthposns [lsearch -all -integer -index 0 $dir_depths_remaining $dnext] + set nextdepthposns [lsort -integer -decreasing $nextdepthposns[set nextdepthposns {}]];#remove later elements first + foreach posn $nextdepthposns { + set id [lindex $dir_depths_remaining $posn $i_itemid] + set ndirname [lindex $folders $id] + #set ndirname $cont/$item + #set item [lindex $dir_depths_remaining $posn $i_item] + #set ndirname [lindex $ndir 1] + if {[string match $nm/* $ndirname]} { + #puts stdout "dir $nm adding subdir size $ndirname" + #puts stdout "incr $nm from $ary($nm,bytes) plus $ary($ndirname,bytes)" + incr bytecount [lindex $dir_depths_remaining $posn $i_size] + set dir_depths_remaining [lreplace $dir_depths_remaining[set dir_depths_remaining {}] $posn $posn] + } + } + lset dir_depths_longfirst $i $i_size $bytecount + set p [lsearch -index $i_index -integer $dir_depths_remaining $i] + lset dir_depths_remaining $p $i_size $bytecount + #set ary($nm,bytes) $bytecount + incr i + } + } + #set dir_depths_longfirst [lsort -index 1 -decreasing $dir_depths_longfirst] + # + + set retval [list] + #copy across the bytecounts + for {set i 0} {$i < [llength $dir_depths_longfirst]} {incr i} { + set posn [lindex $dir_depths_longfirst $i $i_index] + set bytes [lindex $dir_depths_longfirst $i $i_size] + lset dirs_as_encountered $posn $i_size $bytes + } + foreach dirinfo [lreverse $dirs_as_encountered] { + set id [lindex $dirinfo $i_itemid] + set depth [lindex $dirinfo $i_depth] + if {($opt_depth >= 0) && $depth > $opt_depth} { + continue + } + set path [lindex $folders $id] + #set path $cont/$item + set item [lindex $dirinfo $i_item] + set bytes [lindex $dirinfo $i_size] + set size [expr {$bytes / [set $switch]}] + lappend retval [list $size $path] + } + # copyright 2002 by The LIGO Laboratory + return $retval + } + namespace eval active { + variable functions [list du_dirlisting ""] + variable functions_known [dict create] + + #known functions from lib namespace + dict set functions_known du_dirlisting [list du_dirlisting_twapi du_dirlisting_generic du_dirlisting_unix du_dirlisting_undecided] + + proc show_functions {} { + variable functions + variable functions_known + set msg "" + dict for {callname implementations} $functions_known { + append msg "callname: $callname" \n + foreach imp $implementations { + if {[dict get $functions $callname] eq $imp} { + append msg " $imp (active)" \n + } else { + append msg " $imp" \n + } + } + } + return $msg + } + proc set_active_function {callname implementation} { + variable functions + variable functions_known + if {$callname ni [dict keys $functions_known]} { + error "unknown function callname $callname" + } + if {$implementation ni [dict get $functions_known $callname]} { + error "unknown implementation $implementation for callname $callname" + } + dict set functions $callname $implementation + + catch {rename ::punk::du::active::$callname ""} + namespace eval ::punk::du::active [string map [list %imp% $implementation %call% $callname] { + namespace import ::punk::du::lib::%imp% + rename %imp% %call% + }] + + return $implementation + } + proc get_active_function {callname} { + variable functions + variable functions_known + if {$callname ni [dict keys $functions_known]} { + error "unknown function callname $callname known functions: [dict keys $functions_known]" + } + return [dict get $functions $callname] + } + + + #where we import & the appropriate du_listing.. function for the platform + } + namespace eval lib { + variable du_literal + variable winfile_attributes [list 16 directory 32 archive 1024 reparse_point 18 [list directory hidden] 34 [list archive hidden] ] + #caching this is faster than calling twapi api each time.. unknown if twapi is calculating from bitmask - or calling windows api + #we could work out all flags and calculate from bitmask.. but it's not necessarily going to be faster than some simple caching mechanism like this + + proc decode_win_attributes {bitmask} { + variable winfile_attributes + if {[dict exists $winfile_attributes $bitmask]} { + return [dict get $winfile_attributes $bitmask] + } else { + #list/dict shimmering? + return [lindex [lappend winfile_attributes $bitmask [twapi::decode_file_attributes $bitmask]] end] + } + } + proc attributes_twapi {path {detail basic}} { + try { + set iterator [twapi::find_file_open $path -detail $detail] ;# -detail full only adds data to the altname field + if {[twapi::find_file_next $iterator iteminfo]} { + set attrinfo [decode_win_attributes [dict get $iteminfo attrs]] + set result [dict create -archive 0 -hidden 0 -longname $path -readonly 0 -shortname {} -system 0] + if {"hidden" in $attrinfo} { + dict set result -hidden 1 + } + if {"system" in $attrinfo} { + dict set result -system 1 + } + if {"readonly" in $attrinfo} { + dict set result -readonly 1 + } + dict set result -shortname [dict get $iteminfo altname] + dict set result -rawflags $attrinfo + set extras [list] + #foreach prop {ctime atime mtime size} { + # lappend extras $prop [dict get $iteminfo $prop] + #} + #dict set result -extras $extras + dict set result -raw $iteminfo + return $result + } else { + error "could not read attributes for $path" + } + } finally { + catch {twapi::find_file_close $iterator} + } + } + + #todo - review 'errors' key. We have errors relating to containing folder and args vs per child-item errors - additional key needed? + namespace export du_dirlisting_twapi du_dirlisting_generic du_dirlisting_unix du_dirlisting_undecided + # get listing without using unix-tools (may not be installed on the windows system) + # this dirlisting is customised for du - so only retrieves dirs,files,filesizes (minimum work needed to perform du function) + # This also preserves path rep for elements in the dirs/folders keys etc - which can make a big difference in performance + proc du_dirlisting_twapi {folderpath args} { + set defaults [dict create\ + -glob *\ + -with_sizes 1\ + -with_times 1\ + ] + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_glob [dict get $opts -glob] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_with_sizes [dict get $opts -with_sizes] + set ftypes [list f d l] + if {"$opt_with_sizes" in {0 1}} { + #don't use string is boolean - (f false vs f file!) + #only accept 0|1 + if {$opt_with_sizes} { + set sized_types $ftypes + } else { + set sized_types [list] + } + } else { + set sized_types $opt_with_sizes + } + if {[llength $sized_types]} { + foreach st $sized_types { + if {$st ni $ftypes} { + error "du_dirlisting_twapi unrecognized element in -with_sizes '$st'" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_with_times [dict get $opts -with_times] + if {"$opt_with_times" in {0 1}} { + if {$opt_with_times} { + set timed_types $ftypes + } else { + set timed_types [list] + } + } else { + set timed_types $opt_with_times + } + if {[llength $timed_types]} { + foreach item $timed_types { + if {$item ni $ftypes} { + error "du_dirlisting_twapi unrecognised element in -with-times '$item'" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + + set errors [dict create] + set altname "" ;#possible we have to use a different name e.g short windows name or dos-device path //?/ + # return it so it can be stored and tried as an alternative for problem paths + #puts stderr ">>> glob: $opt_glob" + #REVIEW! windows api pattern matchttps://www.red-gate.com/simple-talk/blogs/the-unexpected-behaviour-of-directoryinfo-getfiles-with-three-letter-extensions/hing is .. weird. partly due to 8.3 filenames + #https://www.red-gate.com/simple-talk/blogs/the-unexpected-behaviour-of-directoryinfo-getfiles-with-three-letter-extensions/ + #we will certainly need to check the resulting listing with our supplied glob.. but maybe we will have to change the glob passed to find_file_open too. + # using * all the time may be inefficient - so we might be able to avoid that in some cases. + try { + #glob of * will return dotfiles too on windows + set iterator [twapi::find_file_open [file join $folderpath $opt_glob] -detail basic] ;# -detail full only adds data to the altname field + } on error args { + try { + if {[string match "*denied*" $args]} { + #output similar format as unixy du + puts stderr "[file dirname $folderpath] '[file tail $folderpath]':$args" + dict lappend errors $folderpath $::errorCode + return [list dirs {} vfsmounts {} links {} files {} filesizes {} sizes {} times {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {} opts $opts errors $errors] + } + if {[string match "*TWAPI_WIN32 59*" $::errorCode]} { + puts stderr "[file dirname $folderpath] '[file tail $folderpath]':$args (possibly blocked by permissions or share config e.g follow symlinks = no on samba)" + puts stderr " (errorcode: $::errorCode)\n" + dict lappend errors $folderpath $::errorCode + return [list dirs {} vfsmounts {} links {} files {} filesizes {} sizes {} times {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {} opts $opts errors $errors] + } + + + #errorcode TWAPI_WIN32 2 {The system cannot find the file specified.} + #This can be a perfectly normal failure to match the glob.. which means we shouldn't really warn or error + #The find-all glob * won't get here because it returns . & .. + #so we should return immediately only if the glob has globchars ? or * but isn't equal to just "*" ? (review) + #Note that windows glob ? seems to return more than just single char results - it includes .. - which differs to tcl glob + #also ???? seems to returns items 4 or less - not just items exactly 4 long (review - where is this documented?) + if {$opt_glob ne "*" && [regexp {[?*]} $opt_glob]} { + if {[string match "*TWAPI_WIN32 2 *" $::errorCode]} { + #looks like an ordinary no results for chosen glob + return [list dirs {} vfsmounts {} links {} files {} filesizes {} sizes {} times {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {} opts $opts errors $errors] + } + } + + + if {[set plen [pathcharacterlen $folderpath]] >= 250} { + set errmsg "error reading folder: $folderpath (len:$plen)\n" + append errmsg "error: $args" \n + append errmsg "errorcode: $::errorCode" \n + # re-fetch this folder with altnames + #file normalize - aside from being slow - will have problems with long paths - so this won't work. + #this function should only accept absolute paths + # + # + #Note: using -detail full only helps if the last segment of path has an altname.. + #To properly shorten we need to have kept track of altname all the way from the root! + #We can .. for now call Tcl's file attributes to get shortname of the whole path - it is *expensive* e.g 5ms for a long path on local ssd + #### SLOW + set fixedpath [dict get [file attributes $folderpath] -shortname] + #### SLOW + + + append errmsg "retrying with with windows altname '$fixedpath'" + puts stderr $errmsg + } else { + set errmsg "error reading folder: $folderpath (len:$plen)\n" + append errmsg "error: $args" \n + append errmsg "errorcode: $::errorCode" \n + set tmp_errors [list $::errorCode] + #possibly an illegal windows filename - easily happens on a machine with WSL or with drive mapped to unix share + #we can use //?/path dos device path - but not with tcl functions + #unfortunately we can't call find_file_open directly on the problem name - we have to call the parent folder and iterate through again.. + #this gets problematic as we go deeper unless we rewrite the .. but we can get at least one level further here + + set fixedtail "" + + set parent [file dirname $folderpath] + set badtail [file tail $folderpath] + set iterator [twapi::find_file_open [file join $parent *] -detail full] ;#retrieve with altnames + while {[twapi::find_file_next $iterator iteminfo]} { + set nm [dict get $iteminfo name] + if {$nm eq $badtail} { + set fixedtail [dict get $iteminfo altname] + break + } + } + + if {![string length $fixedtail]} { + dict lappend errors $folderpath {*}$tmp_errors + puts stderr "[file dirname $folderpath] '[file tail $folderpath]':$args (Unable to retrieve altname to progress further with path - returning no contents for this folder)" + return [list dirs {} vfsmounts {} links {} files {} filesizes {} sizes {} times {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {} opts $opts errors $errors] + } + + #twapi as at 2023-08 doesn't seem to support //?/ dos device paths.. + #Tcl can test only get as far as testing existence of illegal name by prefixing with //?/ - but can't glob inside it + #we can call file attributes on it - but we get no shortname (but we could get shortname for parent that way) + #so the illegalname_fix doesn't really work here + #set fixedpath [punk::winpath::illegalname_fix $parent $fixedtail] + + #this has shortpath for the tail - but it's not the canonical-shortpath because we didn't call it on the $parent part REIEW. + set fixedpath [file join $parent $fixedtail] + append errmsg "retrying with with windows dos device path $fixedpath\n" + puts stderr $errmsg + + } + + if {[catch { + set iterator [twapi::find_file_open $fixedpath/* -detail basic] + } errMsg]} { + puts stderr "[file dirname $folderpath] '[file tail $folderpath]':$args (failed to read even with fixedpath:'$fixedpath')" + puts stderr " (errorcode: $::errorCode)\n" + puts stderr "$errMsg" + dict lappend errors $folderpath $::errorCode + return [list dirs {} vfsmounts {} links {} files {} filesizes {} sizes {} times {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {} opts $opts errors $errors] + } + + + } on error args { + set errmsg "error reading folder: $folderpath\n" + append errmsg "error: $args" \n + append errmsg "errorInfo: $::errorInfo" \n + puts stderr "$errmsg" + puts stderr "FAILED to collect info for folder '$folderpath'" + #append errmsg "aborting.." + #error $errmsg + return [list dirs {} vfsmounts {} links {} files {} filesizes {} sizes {} times {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {} opts $opts errors $errors] + + } + } + set dirs [list] + set files [list] + set filesizes [list] + set allsizes [dict create] + set alltimes [dict create] + + set links [list] + set flaggedhidden [list] + set flaggedsystem [list] + set flaggedreadonly [list] + + while {[twapi::find_file_next $iterator iteminfo]} { + set nm [dict get $iteminfo name] + #recheck glob + #review! + if {![string match $opt_glob $nm]} { + continue + } + set tail_altname [dict get $iteminfo altname] ;#altname of tail - not whole path + set attrinfo [decode_win_attributes [dict get $iteminfo attrs]] + #puts stderr "$iteminfo" + #puts stderr "$nm -> [dict get $iteminfo attrs] -> $attrinfo" + set ftype "" + #attributes applicable to any classification + set fullname [file_join_one $folderpath $nm] + + if {"hidden" in $attrinfo} { + lappend flaggedhidden $fullname + } + if {"system" in $attrinfo} { + lappend flaggedsystem $fullname + } + if {"readonly" in $attrinfo} { + lappend flaggedreadonly $fullname + } + + #main classification + if {"reparse_point" in $attrinfo} { + #this concept doesn't correspond 1-to-1 with unix links + #https://learn.microsoft.com/en-us/windows/win32/fileio/reparse-points + #review - and see which if any actually belong in the links key of our return + + + #One thing it could be, is a 'mounted folder' https://learn.microsoft.com/en-us/windows/win32/fileio/determining-whether-a-directory-is-a-volume-mount-point + # + #we will treat as zero sized for du purposes.. review - option -L for symlinks like BSD du? + #Note 'file readlink' can fail on windows - reporting 'invalid argument' - according to tcl docs, 'On systems that don't support symbolic links this option is undefined' + #The link may be viewable ok in windows explorer, and cmd.exe /c dir and unix tools such as ls + #if we need it without resorting to unix-tools that may not be installed: exec {*}[auto_execok dir] /A:L {c:\some\path} + #e.g (stripped of headers/footers and other lines) + #2022-10-02 04:07 AM priv [\\?\c:\repo\elixir\gameportal\apps\test\priv] + #Note we will have to parse beyond header fluff as /B strips the symlink info along with headers. + #du includes the size of the symlink + #but we can't get it with tcl's file size + #twapi doesn't seem to have anything to help read it either (?) + #the above was verified with a symlink that points to a non-existant folder.. mileage may vary for an actually valid link + # + #Note also - a shortcut created in explorer with drag and drop to an existant folder is a different animal to a symlink (file with .lnk extension) even though it looks the same in explorer window. + # + #links are techically files too, whether they point to a file/dir or nothing. + + lappend links $fullname + set ftype "l" + } elseif {"directory" in $attrinfo} { + if {$nm in {. ..}} { + continue + } + lappend dirs $fullname + set ftype "d" + } else { + + #review - is anything that isn't a reparse_point or a directory, some sort of 'file' in this context? What about the 'device' attribute? Can that occur in a directory listing of some sort? + lappend files $fullname + if {"f" in $sized_types} { + lappend filesizes [dict get $iteminfo size] + } + set ftype "f" + } + if {$ftype in $sized_types} { + dict set allsizes $fullname [dict create bytes [dict get $iteminfo size]] + } + if {$ftype in $timed_types} { + #convert time from windows (100ns units since jan 1, 1601) to Tcl time (seconds since Jan 1, 1970) + #We lose some precision by not passing the boolean to the large_system_time_to_secs_since_1970 function which returns fractional seconds + #but we need to maintain compatibility with other platforms and other tcl functions so if we want to return more precise times we will need another flag and/or result dict + dict set alltimes $fullname [dict create\ + c [twapi::large_system_time_to_secs_since_1970 [dict get $iteminfo ctime]]\ + a [twapi::large_system_time_to_secs_since_1970 [dict get $iteminfo atime]]\ + m [twapi::large_system_time_to_secs_since_1970 [dict get $iteminfo mtime]]\ + ] + } + } + twapi::find_file_close $iterator + set vfsmounts [get_vfsmounts_in_folder $folderpath] + + set effective_opts $opts + dict set effective_opts -with_times $timed_types + dict set effective_opts -with_sizes $sized_types + + #also determine whether vfs. file system x is *much* faster than file attributes + #whether or not there is a corresponding file/dir add any applicable mountpoints for the containing folder + return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes $filesizes sizes $allsizes times $alltimes flaggedhidden $flaggedhidden flaggedsystem $flaggedsystem flaggedreadonly $flaggedreadonly altname $altname opts $effective_opts errors $errors] + } + proc get_vfsmounts_in_folder {folderpath} { + set vfsmounts [list] + if {![llength [package provide vfs]]} { + return [list] + } + set fpath [punk::objclone $folderpath] + set is_rel 0 + if {[file pathtype $fpath] ne "absolute"} { + set fpath [file normalize $fpath] + set is_rel 1 + } + set known_vfs_mounts [vfs::filesystem info] + foreach mount $known_vfs_mounts { + if {[punk::mix::base::lib::path_a_above_b $fpath $mount]} { + if {([llength [file split $mount]] - [llength [file split $fpath]]) == 1} { + #the mount is in this folder + if {$is_rel} { + lappend vfsmounts [file join $folderpath [file tail $mount]] + } else { + lappend vfsmounts $mount + } + } + } + } + return $vfsmounts + } + #work around the horrible tilde-expansion thing (not needed for tcl 9+) + proc file_join_one {base newtail} { + if {[string index $newtail 0] ne {~}} { + return [file join $base $newtail] + } + return [file join $base ./$newtail] + } + + + #this is the cross-platform pure-tcl version - which calls glob multiple times to make sure it gets everythign it needs and can ignore everything it needs to. + #These repeated calls to glob will be a killer for performance - especially on a network share or when walking a large directory structure + proc du_dirlisting_generic {folderpath args} { + set defaults [dict create\ + -glob *\ + -with_sizes 0\ + -with_times 0\ + ] + set errors [dict create] + set known_opts [dict keys $defaults] + foreach k [dict keys $args] { + if {$k ni $known_opts} { + error "du_dirlisting_generic unknown-option $k" + } + } + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_glob [dict get $opts -glob] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_with_sizes [dict get $opts -with_sizes] + set ftypes [list f d l] + if {"$opt_with_sizes" in {0 1}} { + #dn't use string is boolean (false vs f problem) + if {$opt_with_sizes} { + set sized_types $ftypes + } else { + set sized_types [list] + } + } else { + set sized_types $opt_with_sizes + } + if {[llength $sized_types]} { + foreach st $sized_types { + if {$st ni $ftypes} { + error "du_dirlisting_generic unrecognized element in -with_sizes '$st'" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_with_times [dict get $opts -with_times] + if {"$opt_with_times" in {0 1}} { + if {$opt_with_times} { + set timed_types $ftypes + } else { + set timed_types [list] + } + } else { + set timed_types $opt_with_times + } + if {[llength $timed_types]} { + foreach item $timed_types { + if {$item ni $ftypes} { + error "du_dirlisting_generic unrecognised element in -with-times '$item'" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + # The repeated globs are a source of slowness for this function. + #TODO - we could minimize the number of globs if we know we need to do a file stat and/or file attributes on each entry anyway + #For the case where we don't need times,sizes or other metadata - it is faster to do multiple globs + #This all makes this function complicated to gather the required data efficiently. + + #note platform differences between what is considered hidden make this tricky. + # on windows 'glob .*' will not return some hidden dot items but will return . .. and glob -types hidden .* will not return some dotted items + # glob -types hidden * on windows will not necessarily return all dot files/folders + # unix-like platforms seem to consider all dot files as hidden so processing is more straightforward + # we need to process * and .* in the same glob calls and remove duplicates + # if we do * and .* in separate iterations of this loop we lose the ability to filter duplicates easily + + #note - with this design, we can't glob for all except dotfiles - this is for cross-platform consistency and efficiency (Review). + #dotfiles aren't considered hidden on all platforms + #some sort of antiglob is a possible enhancement and more consistent with the view that leading dot should be treated as any other filename character in this context. + if {$opt_glob eq "*"} { + #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' + #set parent [lindex $folders $folderidx] + set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*] + #set hdirs {} + set dirs [glob -nocomplain -dir $folderpath -types d * .*] + + set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*] + #set hlinks {} + set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. struct::set difference will remove + #set links [lsort -unique [concat $hlinks $links[unset links]]] + + set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} * .*] + #set hfiles {} + set files [glob -nocomplain -dir $folderpath -types f * .*] + #set files {} + } else { + set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} $opt_glob] + set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] + + set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob] + set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. struct::set difference will remove + + set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob] + set files [glob -nocomplain -dir $folderpath -types f $opt_glob] + } + + #note struct::set difference produces unordered result + #struct::set difference removes duplicates + #remove links and . .. from directories, remove links from files + set files [struct::set difference [concat $hfiles $files[unset files]] $links] + set dirs [struct::set difference [concat $hdirs $dirs[unset dirs]] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] + set links [lsort -unique [concat $links $hlinks]] + + set meta_dict [dict create] + set meta_types [concat $sized_types $timed_types] + #known tcl stat keys 2023 - review + set empty_stat_dict [dict create atime {} ctime {} dev {} gid {} ino {} mode {} mtime {} nlink {} size {} type {} uid {}] + #make sure we call file stat only once per item + set statkeys [list] + if {[llength $meta_types]} { + foreach ft {f d l} lvar {files dirs links} { + if {"$ft" in $meta_types} { + foreach path [set $lvar] { + #caller may have read perm on the containing folder - but not on child item - so file stat could raise an error + if {![catch {file stat $path arrstat} errM]} { + dict set meta_dict $path [dict create shorttype $ft {*}[array get arrstat]] + } else { + dict lappend errors $path "file stat error: $errM" + dict set meta_dict $path [dict create shorttype $ft {*}$empty_stat_dict] + } + } + } + } + } + set fsizes [list] + set allsizes [dict create] + set alltimes [dict create] + #review birthtime field of stat? cross-platform differences ctime etc? + dict for {path pathinfo} $meta_dict { + set ft [dict get $pathinfo shorttype] + if {$ft in $sized_types} { + dict set allsizes $path [dict create bytes [dict get $pathinfo size]] + if {$ft eq "f"} { + lappend fsizes [dict get $pathinfo size] + } + } + if {$ft in $timed_types} { + dict set alltimes $path [dict create c [dict get $pathinfo ctime] a [dict get $pathinfo atime] m [dict get $pathinfo mtime]] + } + } + if {"f" in $sized_types} { + if {[llength $fsizes] ne [llength $files]} { + dict lappend errors $folderpath "failed to retrieve all file sizes" + } + } + + + if {"windows" eq $::tcl_platform(platform)} { + set flaggedhidden [concat $hdirs $hfiles $hlinks] + } else { + #unix dotted files/folders are not 'flagged' as such - it's a convention - so the client can use the same convention to decide if something is hidden + #this allows us to return less data - but more importantly - reserve flaggedhidden for systems where such a flag exists and avoid conflating the different concepts of what is hidden + set flaggedhidden {} + } + + set vfsmounts [get_vfsmounts_in_folder $folderpath] + + set effective_opts $opts + dict set effective_opts -with_times $timed_types + dict set effective_opts -with_sizes $sized_types + + return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes $fsizes sizes $allsizes times $alltimes flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {} opts $effective_opts errors $errors] + } + + proc du_dirlisting_tclvfs {folderpath args} { + set defaults [dict create\ + -glob *\ + -with_sizes 0\ + -with_times 0\ + ] + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_glob [dict get $opts -glob] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_with_sizes [dict get $opts -with_sizes] + set ftypes [list f d l] + if {"$opt_with_sizes" in {0 1}} { + #dn't use string is boolean (false vs f problem) + if {$opt_with_sizes} { + set sized_types $ftypes + } else { + set sized_types [list] + } + } else { + set sized_types $opt_with_sizes + } + if {[llength $sized_types]} { + foreach st $sized_types { + if {$st ni $ftypes} { + error "du_dirlisting_generic unrecognized element in -with_sizes '$st'" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_with_times [dict get $opts -with_times] + if {"$opt_with_times" in {0 1}} { + if {$opt_with_times} { + set timed_types $ftypes + } else { + set timed_types [list] + } + } else { + set timed_types $opt_with_times + } + if {[llength $timed_types]} { + foreach item $timed_types { + if {$item ni $ftypes} { + error "du_dirlisting_generic unrecognised element in -with-times '$item'" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + + set errors [dict create] + if {$opt_glob eq "*"} { + set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs + #review - how are links handled in vfs? presumably if the vfs is a full implementation they should work at least within the vfs? + set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove + set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files + } else { + set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] + set links [glob -nocomplain -dir $folderpath -types l $opt_glob] + set files [glob -nocomplain -dir $folderpath -types f $opt_glob] + } + #remove any links from our dirs and files collections + set dirs [struct::set difference $dirs[unset dirs] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] + set files [struct::set difference $files[unset files] $links] + #nested vfs mount.. REVIEW - does anything need special handling? + set vfsmounts [get_vfsmounts_in_folder $folderpath] + + set meta_dict [dict create] + set meta_types [concat $sized_types $timed_types] + #known tcl stat keys 2023 - review + set empty_stat_dict [dict create atime {} ctime {} dev {} gid {} ino {} mode {} mtime {} nlink {} size {} type {} uid {}] + #make sure we call file stat only once per item + set statkeys [list] + if {[llength $meta_types]} { + foreach ft {f d l} lvar {files dirs links} { + if {"$ft" in $meta_types} { + foreach path [set $lvar] { + #caller may have read perm on the containing folder - but not on child item - so file stat could raise an error + if {![catch {file stat $path arrstat} errM]} { + dict set meta_dict $path [dict create shorttype $ft {*}[array get arrstat]] + } else { + dict lappend errors $path "file stat error: $errM" + dict set meta_dict $path [dict create shorttype $ft {*}$empty_stat_dict] + } + } + } + } + } + set fsizes [list] + set allsizes [dict create] + set alltimes [dict create] + #review birthtime field of stat? cross-platform differences ctime etc? + dict for {path pathinfo} $meta_dict { + set ft [dict get $pathinfo shorttype] + if {$ft in $sized_types} { + dict set allsizes $path [dict create bytes [dict get $pathinfo size]] + if {$ft eq "f"} { + lappend fsizes [dict get $pathinfo size] + } + } + if {$ft in $timed_types} { + dict set alltimes $path [dict create c [dict get $pathinfo ctime] a [dict get $pathinfo atime] m [dict get $pathinfo mtime]] + } + } + if {"f" in $sized_types} { + if {[llength $fsizes] ne [llength $files]} { + dict lappend errors $folderpath "failed to retrieve all file sizes" + } + } + + + set effective_opts $opts + dict set effective_opts -with_times $timed_types + dict set effective_opts -with_sizes $sized_types + + return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes $fsizes sizes $allsizes times $alltimes flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {} opts $effective_opts errors $errors] + } + + #we can halve the number of round trips on unix-like systems, where 'hidden' always corresponds to dotted files + proc du_dirlisting_unix {folderpath args} { + set defaults [dict create\ + -glob *\ + -with_sizes 0\ + -with_times 0\ + ] + set errors [dict create] + dict lappend errors $folderpath "metdata support incomplete - prefer du_dirlisting_generic" + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_glob [dict get $opts -glob] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_with_sizes [dict get $opts -with_sizes] + set ftypes [list f d l] + if {"$opt_with_sizes" in {0 1}} { + #dn't use string is boolean (false vs f problem) + if {$opt_with_sizes} { + set sized_types $ftypes + } else { + set sized_types [list] + } + } else { + set sized_types $opt_with_sizes + } + if {[llength $sized_types]} { + foreach st $sized_types { + if {$st ni $ftypes} { + error "du_dirlisting_generic unrecognized element in -with_sizes '$st'" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_with_times [dict get $opts -with_times] + if {"$opt_with_times" in {0 1}} { + if {$opt_with_times} { + set timed_types $ftypes + } else { + set timed_types [list] + } + } else { + set timed_types $opt_with_times + } + if {[llength $timed_types]} { + foreach item $timed_types { + if {$item ni $ftypes} { + error "du_dirlisting_generic unrecognised element in -with-times '$item'" + } + } + } + + #this is not consistent with standard way * works for unix folders - but it is consistent with behaviour of this facility on windows + if {$opt_glob eq "*"} { + set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs + set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove + set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files + } else { + set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] + set links [glob -nocomplain -dir $folderpath -types l $opt_glob] + set files [glob -nocomplain -dir $folderpath -types f $opt_glob] + } + #remove any links from our dirs and files collections + set dirs [struct::set difference $dirs[unset dirs] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] + set files [struct::set difference $files[unset files] $links] + set vfsmounts [get_vfsmounts_in_folder $folderpath] + + set effective_opts $opts + dict set effective_opts -with_times $timed_types + dict set effective_opts -with_sizes $sized_types + + + return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes {} times {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {} opts $opts errors $errors] + } + + + + proc du_lit value { + variable du_literal + if {![info exists du_literal($value)]} { + set du_literal($value) $value + } + return $du_literal($value) + } + + #v1 + proc du_new_eachdirtail {dirtails depth parentfolderidx} { + set newlist {} + upvar folders folders + set parentpath [lindex $folders $parentfolderidx] + set newindex [llength $folders] + foreach dt $dirtails { + lappend folders [file join $parentpath [du_lit $dt]]; #store as a 'path' rather than a string (see tcl::unsupported::representation) + lappend newlist [::list $depth $parentfolderidx $newindex [du_lit $dt] [expr {0}]] + incr newindex + } + return $newlist + } + proc du_new_eachdir {dirpaths depth parentfolderidx} { + set newlist {} + upvar folders folders + set newindex [llength $folders] + foreach dp $dirpaths { + lappend folders $dp + #puts stdout "--->$dp" + lappend newlist [::list $depth $parentfolderidx $newindex [du_lit [file tail $dp]] [expr {0}]] + incr newindex + } + return $newlist + } + + #same implementation as punk::strlen + #get length of path which has internal rep of path - maintaining path/list rep without shimmering to string representation. + proc pathcharacterlen {pathrep} { + append str2 $pathrep {} + string length $str2 + } + #just an experiment + proc pathcharacterlen1 {pathrep} { + #This works - but is unnecessarily complex + set l 0 + set parts [file split $pathrep] + if {[llength $parts] < 2} { + return [string length [lindex $parts 0]] + } + foreach seg $parts { + incr l [string length $seg] + } + return [expr {$l + [llength $parts] -2}] + } + #slower - doesn't work for short paths like c:/ + proc pathcharacterlen2 {pathrep} { + return [tcl::mathop::+ {*}[lmap v [set plist [file split $pathrep]] {[string length $v]}] [llength $plist] -2] + } + + #Strip using lengths without examining path components + #without normalization is much faster + proc path_strip_alreadynormalized_prefixdepth {path prefix} { + set tail [lrange [file split $path] [llength [file split $prefix]] end] + if {[llength $tail]} { + return [file join {*}$tail] + } else { + return "" + } + } + + proc du_dirlisting_undecided {folderpath args} { + if {"windows" eq $::tcl_platform(platform)} { + set loadstate [zzzload::pkg_require twapi] + if {$loadstate ni [list loading failed]} { + package require twapi ;#should be fast once twapi dll loaded in zzzload thread + set ::punk::du::has_twapi 1 + punk::du::active::set_active_function du_dirlisting du_dirlisting_twapi + tailcall du_dirlisting_twapi $folderpath {*}$args + } else { + if {$loadstate eq "failed"} { + puts stderr "punk::du defaulting to du_dirlisting_generic because twapi load failed" + punk::du::active::set_active_function du_dirlisting du_dirlisting_generic + } + tailcall du_dirlisting_generic $folderpath {*}$args + } + } else { + punk::du::active::set_active_function du_dirlisting du_dirlisting_unix + tailcall du_dirlisting_unix $folderpath {*}$args + } + } + + + } + package require natsort + #interp alias {} du {} .=args>* punk::du |> .=>1 natsort::sort -cols 1 |> list_as_lines * punk::du::du |> .=>1 natsort::sort -cols 1 -outputformat words |> list_as_lines * punk::du::du |> .=>1 natsort::sort -cols 1 -outputformat csv -outputformatoptions {\r\t\t\t} |> list_as_lines -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#Copyright (c) 2023 Julian Noble +#Copyright (c) 2012-2018 Andreas Kupries +# - code from A.K's 'kettle' project used in this module +# +# @@ Meta Begin +# Application punk::repo 0.1.1 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# +# path/repo functions +# +if {$::tcl_platform(platform) eq "windows"} { + package require punk::winpath +} else { + catch {package require punk::winpath} +} +package require fileutil; #tcllib +package require punk::mix::base ;#uses core functions from punk::mix::base::lib namespace e.g cksum_path +package require punk::mix::util + + +# -- --- --- --- --- --- --- --- --- --- --- +# For performance/efficiency reasons - use file functions on paths in preference to string operations +# e.g use file join +# branch to avoid unnecessary calls to 'pwd' or 'file normalize' - which can be surprisingly expensive operations (as at tcl 8.7 2023) +# pwd is only expensive if we treat it as a string instead of a list/path +# e.g +# > time {set x [pwd]} +# 5 microsoeconds.. no problem +# > time {set x [pwd]} +# 4 microsoeconds.. still no problem +# > string length $x +# 45 +# > time {set x [pwd]} +# 1372 microseconds per iteration ;#!! values above 0.5ms common.. and that's a potential problem in loops that trawl filesystem +# The same sorts of timings occur with file normalize +# also.. even if we build up a path with file join from a base value that has already been normalized - the subsequent normalize will be expensive +# -- --- --- --- --- --- --- --- --- --- --- + +namespace eval punk::repo { + + #Todo - investigate proper way to install a client-side commit hook in the fossil project + #Then we may still use this proxy to check the hook - but the required checks will occur when another shell used + proc fossil_proxy {args} { + set start_dir [pwd] + set fosroot [find_fossil $start_dir] + set fossilcmd [lindex $args 0] + + set no_warning_commands [list "help" "dbstat" "grep" "diff" "xdiff" "cat" "version"] + if {$fossilcmd ni $no_warning_commands } { + set repostate [find_repos $start_dir] + } + + set no_prompt_commands [list "status" "info" {*}$no_warning_commands] + + + if {$fossilcmd ni $no_prompt_commands} { + set fossilrepos [dict get $repostate fossil] + if {[llength $fossilrepos] > 1} { + puts stdout [dict get $repostate warnings] + puts stdout "Operating on inner fossil repository: [lindex $fossilrepos 0]" + puts stdout "Use FOSSIL instead of fossil to avoid this prompt and warning" + set answer [askuser "Are you sure you want to perform the operation on this repo? Y/N"] + if {[string tolower $answer] ne "y"} { + return + } + } + } + if {$fossilcmd eq "init"} { + #check if the path to .fossil is within an outer repo area.. offer to locate it somewhere else + set repos [dict get $repostate repos] + if {[llength $repos]} { + set chosenfossil [lindex $args end] + #if the user is naming it other than .fossil - assume they know what they're doing. + if {[string match *.fossil $chosenfossil]} { + set norm_chosen [file normalize $chosenfossil] + set fdir [file dirname $norm_chosen] + set toprepo_info [lindex $repos end] ;#choose shortest path ie topmost + set toprepo [lindex $toprepo_info 0] + if {[punk::mix::base::lib::path_a_atorbelow_b $fdir $toprepo]} { + set fproj [file rootname [file tail $norm_chosen]] + puts stdout "Chosen .fossil location is within outer repository at $toprepo" + set answer [askuser "Would you like the opportunity to choose a different location for the .fossil file from a menu? Y/N"] + if {[string tolower $answer] eq "y"} { + set repodir [fossil_get_repository_folder_for_project $fproj -extrachoice $fdir] + if {[string length $repodir]} { + puts stdout "LOCATION: $repodir/$fproj.fossil" + set args [lrange $args 0 end-1] + lappend args $repodir/$fproj.fossil + } else { + puts stderr "No directory found/selected - aborting" + return + } + } + } + } + } + } + if {$fossilcmd eq "commit"} { + if {[llength [file split $fosroot]]} { + if {[file exists [file join $fosroot src/buildsuites]]} { + puts stderr "Todo - check buildsites/suite/projects for current branch/tag and update download_and_build_config" + } + } + } elseif {$fossilcmd in [list "info" "status"]} { + #emit warning whether or not multiple fossil repos + puts stdout [dict get $repostate warnings] + } + set fossil_prog [auto_execok fossil] + if {$fossil_prog ne ""} { + {*}$fossil_prog {*}$args + } else { + puts stderr "fossil command not found. Please install fossil" + } + } + interp alias "" fossil "" punk::repo::fossil_proxy + + if {[auto_execok fossil] ne ""} { + interp alias "" FOSSIL "" {*}[auto_execok fossil] + } + + proc askuser {question} { + puts stdout $question + flush stdout + set stdin_state [fconfigure stdin] + try { + fconfigure stdin -blocking 1 + set answer [gets stdin] + } finally { + fconfigure stdin -blocking [dict get $stdin_state -blocking] + } + return $answer + } + proc is_fossil {{path {}}} { + if {$path eq {}} { set path [pwd] } + return [expr {[find_fossil $path] ne {}}] + } + proc is_git {{path {}}} { + if {$path eq {}} { set path [pwd] } + return [expr {[find_git $path] ne {}}] + } + #tracked repo - but may not be a project + proc is_repo {{path {}}} { + if {$path eq {}} { set path [pwd] } + return [expr {[isfossil] || [is_git]}] + } + proc is_candidate {{path {}}} { + if {$path eq {}} { set path [pwd] } + return [expr {[find_candidate $path] ne {}}] + } + proc is_project {{path {}}} { + if {$path eq {}} { set path [pwd] } + return [expr {[find_project $path] ne {}}] + } + + + proc find_fossil {{path {}}} { + if {$path eq {}} { set path [pwd] } + scanup $path is_fossil_root + } + + proc find_git {{path {}}} { + if {$path eq {}} { set path [pwd] } + scanup $path is_git_root + } + proc find_candidate {{path {}}} { + if {$path eq {}} { set path [pwd] } + scanup $path is_candidate_root + } + proc find_repo {{path {}}} { + if {$path eq {}} { set path [pwd] } + #find the closest (lowest in dirtree) repository + set f_root [find_fossil $path] + set g_root [find_git $path] + if {[string length $f_root]} { + if {[string length $g_root]} { + if {[punk::mix::base::lib::path_a_below_b $f_root $g_root]} { + return $f_root + } else { + return $g_root + } + } else { + return $f_root + } + } else { + if {[string length $g_root]} { + return $g_root + } else { + return "" + } + } + } + proc find_project {{path {}}} { + if {$path eq {}} { set path [pwd] } + scanup $path is_project_root + } + + proc is_fossil_root {{path {}}} { + if {$path eq {}} { set path [pwd] } + #from kettle::path::is.fossil + foreach control { + _FOSSIL_ + .fslckout + .fos + } { + set control $path/$control + if {[file exists $control] && [file isfile $control]} {return 1} + } + return 0 + } + + #review - is a .git folder sufficient? + #consider git rev-parse --git-dir ? + proc is_git_root {{path {}}} { + if {$path eq {}} { set path [pwd] } + set control [file join $path .git] + expr {[file exists $control] && [file isdirectory $control]} + } + proc is_repo_root {{path {}}} { + if {$path eq {}} { set path [pwd] } + expr {[is_fossil_root $path] || [is_git_root $path]} + } + #require a minimum of /src and /modules|lib|scriptapps|*.vfs - and that it's otherwise sensible + proc is_candidate_root {{path {}}} { + if {$path eq {}} { set path [pwd] } + if {[file pathtype $path] eq "relative"} { + set normpath [punk::repo::norm $path] + } else { + set normpath $path + } + set unwise_paths [list "/" "/usr/local" "/usr/local/bin" "/usr/local/lib" "c:/windows"] + if {[string tolower $normpath] in $unwise_paths} { + return 0 + } + if {[file pathtype [string trimright $normpath /]] eq "volumerelative"} { + #tcl 8.6/8.7 cd command doesn't preserve the windows "ProviderPath" (per drive current working directory) + return 0 + } + + #review - adjust to allow symlinks to folders? + foreach required { + src + } { + set req $path/$required + if {(![file exists $req]) || ([file type $req] ne "directory") } {return 0} + } + + set src_subs [glob -nocomplain -dir $path/src -types d -tail *] + if {"modules" in $src_subs || "lib" in $src_subs || "scriptapps" in $src_subs} { + return 1 + } + foreach sub $src_subs { + if {[string match *.vfs $sub]} { + return 1 + } + } + + #todo - breadth first search with depth limit (say depth 3?) for *.tm or *.tcl as another positive qualifier for this dir to be a project-root + #we probably don't want to deep search a src folder in case the user is accidentally in some other type of project's tree + #such a src tree could be very large, so if we don't find tcl indicators near the root it's a good bet this isn't a candidate + + return 0 + } + #keep this message in sync with the programmed requirements of is_candidate_root + #message is not titled - it is intended to be output along with more contextual information from the calling site. + proc is_candidate_root_requirements_msg {} { + set msg "" + append msg "./src directory must exist." \n + append msg "At least one of ./src/lib ./src/modules ./src/scriptapps or a ./src/.vfs folder should exist." \n + #append msg "Alternatively - the presence of any .tm or .tcl files within the top few levels of ./src will suffice." \n + return $msg + } + + proc is_project_root {path} { + #review - find a reliable simple mechanism. Noting we have projects based on different templates. + #Should there be a specific required 'project' file of some sort? + + #test for file/folder items indicating fossil or git workdir base + if {(![punk::repo::is_fossil_root $path]) && (![punk::repo::is_git_root $path])} { + return 0 + } + #exclude some known places we wouldn't want to put a project + if {![is_candidate_root $path]} { + return 0 + } + return 1 + } + + #review/tests + #todo - deleted items (e.g for git 1 .D ... ) + #punkcheck uses this to check when copying a source-file to a repo-external location that the file can be tied to a revision. + #we are primarily concerned with the status of existent files (caller should check existence) and whether they belong to the revision that currently applies to the folder being examined. + #we are not concerned with git's staging facility - other than that it needs to be looked at to work out whether the file on disk is currently in a state matching the revision. + # + # -repotypes is an ordered list - if the closest repo is multi-typed the order will determine which is used. + # This deliberately doesn't allow bypassing a sub-repo to look for a higher-level repo in a repo-nest. + # The theory is that sub-repos shouldn't have their contents directly tracked directly by higher-level repos anyway + proc workingdir_state {{abspath {}} args} { + set defaults [list\ + -repotypes [list fossil git]\ + -repopaths ""\ + ] + #prefer fossil if first repo is dual git/fossil + if {$abspath in [dict keys $defaults]} { + set args [list $abspath {*}$args] + set abspath "" + } + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_repotypes [dict get $opts -repotypes] + set opt_repopaths [dict get $opts -repopaths] + if {"$opt_repopaths" ne ""} { + if {([llength $opt_repopaths] % 2 != 0) || ![dict exists $opt_repopaths closest]} { + error "workingdir_state error: -repopaths argument invalid. Expected a dict as retrieved using punk::repo::find_repos" + } + set repopaths $opt_repopaths + } else { + set repopaths [find_repos $abspath] + } + # -- --- --- --- --- --- --- --- --- --- --- --- + + if {$abspath eq ""} {set abspath [pwd]} + if {[file pathtype $abspath] ne "absolute"} { + error "workingdir_state error: absolute path required. Got '$abspath'" + } + if {![file isdirectory $abspath]} { + #shouldn't be passed a file.. but just use containing folder if we were + set abspath [file dirname $abspath] + } + set repodir [dict get $repopaths closest] + set ondisk_repotypes [dict get $repopaths closest_types] + set repotypes_to_query [list] + foreach r $opt_repotypes { + if {$r in $ondisk_repotypes} { + lappend repotypes_to_query $r + } + } + + if {$repodir eq ""} { + error "workingdir_state error: No repository found at or above path '$abspath'" + } + set subpath [punk::mix::util::path_relative $repodir $abspath] + if {$subpath eq "."} { + set subpath "" + } + + set resultdict [dict create repodir $repodir subpath $subpath] + set pathdict [dict create] + + if {![llength $repotypes_to_query]} { + error "No tracking information available for project at $repodir with the chosen repotypes '$opt_repotypes'. Ensure project workingdir is a fossil (or git) checkout" + } + foreach rt $repotypes_to_query { + #We need entire list of files in the revision because there is no easy way to get the list of files configured to be ignored + #(aside from attempting to calculate from .fossil-settings ignore-glob or .gitignore) + #This means we can't just use fossil extras or the list of git untracked files + #i.e a file not showing as EDITED/MISSING/EXTRA can't be assumed to be in the revision as it may match an ignore-glob or .gitignore entry + #For this reason we will store 'unchanged' records for both git and fossil so that the combined dict should represent all files in the revision + if {$rt eq "fossil"} { + dict set resultdict repotype fossil + set fossil_cmd [auto_execok fossil] + if {$fossil_cmd eq ""} { + error "workingdir_state error: fossil executable doesn't seem to be available" + } + if {[catch {punk::mix::util::do_in_path $repodir [list exec {*}$fossil_cmd status --all --differ --merge $abspath]} fossilstate]} { + error "workingdir_state error: Unable to retrieve workingdir state using fossil. Errormsg: $fossilstate" + } + # line: checkout: fb971... + set revision [lindex [grep {checkout:*} $fossilstate] 0 1] + #set checkrevision [fossil_revision $abspath] + + + dict set resultdict ahead "" + dict set resultdict behind "" + + foreach ln [split $fossilstate \n] { + if {[string trim $ln] eq ""} {continue} + set space1 [string first " " $ln] + if {$space1 > 1} { + set word1 [string range $ln 0 $space1-1] + if {[string index $word1 end] eq ":"} { + #we've already examined any xxx: header lines we're interested in. + continue + } + } + if {[string match "EDITED *" $ln]} { + set path [string trim [string range $ln [string length "EDITED "] end]] ;#should handle spaced paths + dict set pathdict $path "changed" + } elseif {[string match "ADDED *" $ln]} { + set path [string trim [string range $ln [string length "ADDED "] end]] + dict set pathdict $path "new" + } elseif {[string match "DELETED *" $ln]} { + set path [string trim [string range $ln [string length "DELETED "] end]] + dict set pathdict $path "missing" + } elseif {[string match "MISSING *" $ln]} { + set path [string trim [string range $ln [string length "MISSING "] end]] + dict set pathdict $path "missing" + } elseif {[string match "EXTRA *" $ln]} { + #fossil will explicitly list files in a new folder - as opposed to git which shows just the folder + set path [string trim [string range $ln [string length "EXTRA "] end]] + dict set pathdict $path "extra" + } elseif {[string match "UNCHANGED *" $ln]} { + set path [string trim [string range $ln [string length "UNCHANGED "] end]] + dict set pathdict $path "unchanged" + } else { + #emit for now + puts stderr "unprocessed fossilstate line: $ln" + } + #other entries?? + } + break + } elseif {$rt eq "git"} { + dict set resultdict repotype git + set git_cmd [auto_execok git] + # -uno = suppress ? lines. + # -b = show ranch and tracking info + if {[catch {punk::mix::util::do_in_path $repodir [list exec {*}$git_cmd status --porcelain=2 -b -- $abspath]} gitstate]} { + error "workingdir_state error: Unable to retrieve workingdir state using git. Errormsg: $gitstate" + } + # line: # branch.oid f2d2a... + set revision [lindex [grep {# branch.oid *} $gitstate] 0 2] + if {$revision eq "(initial)"} { + puts stderr "workingdir_state: git revision is (initial) - no file state to gather" + break + } + dict set resultdict ahead "" + dict set resultdict behind "" + set aheadbehind [lindex [grep {# branch.ab *} $gitstate] 0] + if {[llength $aheadbehind] > 0} { + lassign [lrange $aheadbehind 2 3] a b + if {$a > 0} { + dict set resultdict ahead [expr {abs($a)}] + } + if {$b < 0} { + dict set resultdict behind [expr {abs($b)}] + } + } + #set checkrevision [git_revision $abspath] + if {[catch {punk::mix::util::do_in_path $repodir [list exec {*}$git_cmd ls-tree -r $revision $abspath]} gitfiles]} { + error "workingdir_state error: Unable to retrieve files for revision '$revision' using git. Errormsg: $gitfiles" + } + + #paths will be relative to $repodir/$subpath + foreach ln [split $gitfiles \n] { + if {[string trim $ln] eq ""} {continue} + #review - spaced paths? + set path [lindex $ln end] + dict set pathdict $path "unchanged" ;#default only - to be overridden with info from gitstate + } + + foreach ln [split $gitstate \n] { + if {[string trim $ln] eq ""} {continue} + if {[string match "#*" $ln]} {continue} + if {[string match "1 *" $ln]} { + # ordinary changed entries + # format: 1 + #review - what does git do for spaced paths? + #for now we will risk treating as a list + set path [lindex $ln end] + set xy [lindex $ln 1] + lassign [split $xy ""] staged unstaged + if {[string match "*M*" $xy]} { + #e.g .M when unstaged M. when staged + dict set pathdict $path "changed" + } elseif {[string match "*D*" $xy]} { + dict set pathdict $path "missing" + } elseif {[string match "*A*" $xy]} { + #e.g A. for new file that has been staged + dict set pathdict $path "new" + } else { + dict set pathdict $path "UNKNOWN" ;#review - fix + } + } elseif {[string match "? *" $ln]} { + #note that git will list a folder entry without going deeper to list contents + set path [string trim [string range $ln [string length "? "] end]] ;#should handle spaced paths + dict set pathdict $path "extra" + } elseif {[string match "2 *" $ln]} { + # renamed or copied entries + # as we don't supply -z option - is tab char. + # format: 2 + #we should mark target of rename as 'new' - consistent with fossil - and stops caller from seeing no entry for an existent file and assuming it already belongs to the revision checkout + lassign [split $ln \t] pretab posttab + set path [lindex $pretab end] + dict set pathdict $path "new" ;#review - if file was first deleted then renamed - is it more appropriately flagged as 'changed' - possibly doesn't matter for revision-membership detection new or changed should be ok + + set pathorig [string trim $posttab] + dict set pathdict $pathorig "missing" + } elseif {[string match "u *" $ln]} { + #Unmerged entries + # format: u

+ # + #presume file on disk not as per revision - treat as changed (?review) + set path [lindex $ln end] + dict set pathdict $path "changed" + } elseif {[string match "! *" $ln]} { + #ignored files - not part of revision + + } else { + #emit for now + puts stderr "unprocessed gitstat line $ln" + } + } + break + } else { + puts stderr "workingdir_state - repotype $rt not supported" + } + } + dict set resultdict revision $revision + dict set resultdict paths $pathdict + return $resultdict + } + proc workingdir_state_summary {repostate args} { + if {![dict exists $repostate repotype] || ![dict exists $repostate paths]} { + error "workingdir_state_summary error repostate doesn't appear to be a repostate dict. (use workingdir_state to create)" + } + package require overtype + set defaults [dict create\ + -fields {ahead behind unchanged changed new missing extra}\ + ] + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- --- + set opt_fields [dict get $opts -fields] + # -- --- --- --- --- --- --- --- --- --- + + set summary_dict [workingdir_state_summary_dict $repostate] + set repotype [dict get $summary_dict repotype] + set fieldnames [dict create\ + repodir repodir\ + subpath subpath\ + revision revision\ + ahead ahead\ + behind behind\ + repotype repotype\ + unchanged unchanged\ + changed changed\ + new new\ + missing missing\ + extra extra\ + ] + foreach f $opt_fields { + if {$f ni [dict keys $fieldnames]} { + error "workingdir_state_summary error: unknown field $f. known-values: [dict keys $fieldnames]" + } + } + if {$repotype eq "git"} { + dict set fieldnames extra "extra (files/folders)" + } + set col1_fields [list] + set col2_values [list] + foreach f $opt_fields { + lappend col1_fields [dict get $fieldnames $f] + lappend col2_values [dict get $summary_dict $f] + } + set title1 "" + set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1_fields] {string length $v}]] + set col1 [string repeat " " $widest1] + set title2 "" + set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2_values] {string length $v}]] + set col2 [string repeat " " $widest2] + + set result "" + foreach f $col1_fields v $col2_values { + append result "[overtype::left $col1 $f]: [overtype::right $col2 $v]" \n + } + set result [string trimright $result \n] + return $result + } + proc workingdir_state_summary_dict {repostate} { + if {![dict exists $repostate repotype] || ![dict exists $repostate paths]} { + error "workingdir_state_summary_dict error repostate doesn't appear to be a repostate dict. (use workingdir_state to create)" + } + set filestates [dict values [dict get $repostate paths]] + set path_count_fields [list unchanged changed new missing extra] + set state_fields [list ahead behind repodir subpath repotype revision] + set dresult [dict create] + foreach f $state_fields { + dict set dresult $f [dict get $repostate $f] + } + foreach f $path_count_fields { + dict set dresult $f [llength [lsearch -all $filestates $f]] + } + return $dresult + } + #determine nature of possibly-nested repositories (of various types) at and above this path + #Treat an untracked 'candidate' folder as a sort of repository + proc find_repos {path} { + set start_dir $path + + #root is a 'project' if it it meets the candidate requrements and is under repo control + #therefore if project is in the closest_types list - candidate will always be there too - and at least one of git or fossil + #ie 'project' is a derived repo-type + set root_dict [list closest {} closest_types {} fossil {} git {} candidate {} project {} warnings {}] + set msg "" + + #we're only searching in a straight path up the tree looking for a few specific marker files/folder + set fos_search_from $start_dir + set fossils_bottom_to_top [list] + while {[string length [set fosroot [punk::repo::find_fossil $fos_search_from]]]} { + lappend fossils_bottom_to_top $fosroot + set fos_search_from [file dirname $fosroot] + } + dict set root_dict fossil $fossils_bottom_to_top + + set git_search_from $start_dir + set gits_bottom_to_top [list] + while {[string length [set gitroot [punk::repo::find_git $git_search_from]]]} { + lappend gits_bottom_to_top $gitroot + set git_search_from [file dirname $gitroot] + } + dict set root_dict git $gits_bottom_to_top + + set cand_search_from $start_dir + set candidates_bottom_to_top [list] + while {[string length [set candroot [punk::repo::find_candidate $cand_search_from]]]} { + lappend candidates_bottom_to_top $candroot + set cand_search_from [file dirname $candroot] + } + dict set root_dict candidate $candidates_bottom_to_top + + + set projects_bottom_to_top [list] + set pathinfo [list] ;#list of {path plen} elements - for sorting on plen + set path_dict [dict create] ;#key on path - store repo-types as list + foreach repotype [list fossil git candidate] { + set repos [dict get $root_dict $repotype] + if {[llength $repos]} { + foreach p $repos { + if {![dict exists $path_dict $p]} { + dict set path_dict $p $repotype + } else { + if {$repotype eq "candidate"} { + #path exists so this path is tracked and a candidate - therefore a punk 'project' + dict lappend path_dict $p "candidate" "project" + lappend projects_bottom_to_top $p + } else { + dict lappend path_dict $p $repotype + } + } + set plen [llength [file split $p]] + } + } + } + dict set root_dict project $projects_bottom_to_top + + dict for {path repotypes} $path_dict { + lappend pathinfo [list $repotypes $path [llength [file split $path]]] + } + #these root are all inline towards root of drive - so anything of same length should be same path - shorter path must be above another + #we will check equal depth paths are equal strings and raise an error just in case there are problems with the coding for the various path functions used here + #longest path is 'closest' to start_dir + set longest_first [lsort -decreasing -index 2 $pathinfo] + set repos [list] + foreach pinfo $longest_first { + lassign $pinfo types p len + lappend repos [list $p $types] + } + dict set root_dict repos $repos + + set is_fossil_and_project 0; #fossil repo *and* candidate + foreach fos [dict get $root_dict fossil] { + if {$fos in [dict get $root_dict candidate]} { + set is_fossil_and_project 1 + break + } + } + if {(!$is_fossil_and_project)} { + append msg "Not a punk fossil project" \n + } + + if {![llength $longest_first]} { + #no repos or candidate + append msg "No fossil or git tracking found - No candidate project root found" \n + } else { + dict set root_dict closest [lindex $longest_first 0 1] ;#the *path* of the closest to start_dir + dict set root_dict closest_types [lindex $longest_first 0 0] + } + + + set closest_fossil [lindex [dict get $root_dict fossil] 0] + set closest_fossil_len [llength [file split $closest_fossil]] + set closest_git [lindex [dict get $root_dict git] 0] + set closest_git_len [llength [file split $closest_git]] + set closest_candidate [lindex [dict get $root_dict candidate] 0] + set closest_candidate_len [llength [file split $closest_candidate]] + + if {$closest_candidate_len > $closest_fossil_len && $closest_candidate_len > $closest_git_len} { + #only warn if this candidate is *within* a found repo root + append msg "**" \n + append msg "** found folder with /src at or above starting folder - that is below a fossil and/or git repo" \n + append msg "** starting folder : $start_dir" \n + append msg "** untracked : $candroot" \n + if {$closest_fossil_len} { + append msg "** fossil root : $closest_fossil ([punk::mix::util::path_relative $start_dir $closest_fossil])" \n + } + if {$closest_git_len} { + append msg "** git root : $closest_git ([punk::mix::util::path_relative $start_dir $closest_git])" \n + } + append msg "**" \n + } + + + #don't warn if not git - unless also not fossil + if {(![llength [dict get $root_dict fossil]]) && (![llength [dict get $root_dict git]])} { + append msg "No repository located at or above starting folder $start_dir" \n + if {![llength [dict get $root_dict candidate]]} { + append msg "No candidate project root found. " \n + append msg "Searched upwards from '$start_dir' expecting a folder with the following requirements: " \n + append msg [punk::repo::is_candidate_root_requirements_msg] \n + } else { + append msg "Candidate project root found at : $closest_candidate" \n + append msg " - consider putting this folder under fossil control (and/or git)" \n + } + } + + set nestinfo [list] + if {[llength $longest_first] > 1} { + foreach pinfo $longest_first { + lassign $pinfo types p len + lappend nestinfo [list $p [join $types -]] + } + } + if {[string length $nestinfo]} { + set rnestinfo [lreverse $nestinfo] + set col1items [lsearch -all -inline -index 0 -subindices $rnestinfo *] + set col2items [lsearch -all -inline -index 1 -subindices $rnestinfo *] + + package require overtype + set title1 "Path" + set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1items] {punk::strlen $v}]] + set col1 [string repeat " " $widest1] + set title2 "Repo-type(s)" + set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {punk::strlen $v}]] + set col2 [string repeat " " $widest2] + set tablewidth [expr {$widest1 + 1 + $widest2}] + + append msg [string repeat "=" $tablewidth] \n + append msg "Found nested repository structure" \n + append msg "[overtype::left $col1 $title1] [overtype::left $col2 $title2]" \n + + append msg "[string repeat - $widest1] [string repeat - $widest2]" \n + + foreach p $col1items tp $col2items { + append msg "[overtype::left $col1 $p] [overtype::left $col2 $tp]" \n + } + append msg [string repeat "=" $tablewidth] \n + } + + dict set root_dict warnings $msg + + return $root_dict + } + proc fossil_get_repository_file {{path {}}} { + if {$path eq {}} { set path [pwd] } + set fossilcmd [auto_execok fossil] + if {[llength $fossilcmd]} { + do_in_path $path { + set fossilinfo [::exec {*}$fossilcmd info] + } + set matching_lines [punk::repo::grep {repository:*} $fossilinfo] + if {![llength $matching_lines]} { + return "" + } + set trimmedline [string trim [lindex $matching_lines 0]] + set firstcolon [string first : $trimmedline] + set repofile_path [string trim [string range $trimmedline $firstcolon+1 end]] + if {![file exists $repofile_path]} { + puts stderr "Repository file pointed to by fossil configdb doesn't exist: $repofile_path" + return "" + } + return $repofile_path + } else { + puts stderr "fossil_get_repository_file: fossil command unavailable" + return "" + } + } + proc fossil_get_repository_folder_for_project {projectname args} { + + set defaults [list -parentfolder \uFFFF -extrachoice \uFFFF] + set opts [dict merge $defaults $args] + + set opt_parentfolder [dict get $opts -parentfolder] + if {$opt_parentfolder eq "\uFFFF"} { + set opt_parentfolder [pwd] + } + set opt_extrachoice [dict get $opts -extrachoice] + set extrachoice "" + if {$opt_extrachoice ne "\uFFFF"} { + set extrachoice $opt_extrachoice + } + + set startdir $opt_parentfolder + + set fossil_prog [auto_execok fossil] + if {$fossil_prog eq ""} { + puts stderr "Fossil not found. Please install fossil" + return + } + + set fossilinfo [exec {*}$fossil_prog info] ;#will give us the necessary config-db info whether in a project folder or not + set matching_lines [punk::repo::grep {config-db:*} $fossilinfo] + if {[llength $matching_lines] != 1} { + puts stderr "Unable to find config-db info from fossil. Check your fossil installation." + puts stderr "Fossil output was:" + puts stderr "-------------" + puts stderr "$fossilinfo" + puts stderr "-------------" + puts stderr "config-db info:" + puts stderr "$matching_lines" + return + } + set trimmedline [string trim [lindex $matching_lines 0]] + set firstcolon [string first : $trimmedline] + set config_db_path [string trim [string range $trimmedline $firstcolon+1 end]] + if {![file exists $config_db_path]} { + puts stderr "Unable to verify fossil global configuration info at path: $config_db_path" + return + } + set config_db_folder [file dirname $config_db_path] + + #NOTE: we could use fossil all info to detect all locations of .fossil files - but there may be many that are specific to projects if the user wasn't in the habit of using a default location + #Whilst it might detect a central repo folder in a non-standard location - it might also be annoying. + #Todo - a separate environment variable for users to declare one or more locations where they would like to store project .fossil repositories? + + set candidate_repo_folder_locations [list] + #- choose a sensible default based on where fossil put the global config dir - or on the existence of a .fossils folder in a 'standard' location + #verify with user before creating a .fossils folder + #always check env(FOSSIL_HOME) first - but this is designed to locate the global .fossil (or _fossil) file - .fossils repository folder doesn't have to be at the same location + set usable_repo_folder_locations [list] + #If we find one, but it's not writable - add it to another list + set readonly_repo_folder_locations [list] + + #Examine a few possible locations for .fossils folder set + #if containing folder is writable add to candidate list + set testpaths [list] + + if {[info exists ::env(FOSSIL_HOME)]} { + set fossilhome_raw [string trim $::env(FOSSIL_HOME)] + if {![catch {package require Tcl 8.7-}]} { + set fossilhome [file normalize [file tildeexpand $fossilhome_raw]] + } else { + #8.6 + set fossilhome [file normalize $fossilhome_raw] + } + + lappend testpaths [file join $fossilhome .fossils] + } + + if {[info exists ::env(HOME)]} { + set homedir $::env(HOME) ;#use capital for cross-platform + set tp [file join $homedir .fossils] + if {$tp ni $testpaths} { + lappend testpaths $tp + } + } + set tp [file join $config_db_folder .fossils] + if {$tp ni $testpaths} { + lappend testpaths $tp + } + #test our current startdir too in case the user likes to keep their fossils closer to the projects + set tp [file join $startdir .fossils] + if {$tp ni $testpaths} { + lappend testpaths $tp + } + if {[string length $extrachoice]} { + set tp $extrachoice + if {$tp ni $testpaths} { + lappend testpaths $tp + } + } + + + foreach testrepodir $testpaths { + if {[file isdirectory $testrepodir]} { + if {[file writable $testrepodir]} { + lappend usable_repo_folder_locations $testrepodir + } else { + lappend readonly_repo_folder_locations $testrepodir + } + } else { + set repo_parent [file dirname $testrepodir] + if {[file writable $repo_parent]} { + lappend candidate_repo_folder_locations $testrepodir + } + } + } + + set startdir_fossils [glob -nocomplain -dir $startdir -type f *.fossil] + if {[llength $startdir_fossils]} { + #user is already keeping .fossil files directly in curent dir - give them the option to easily keep doing this + #(we don't add it if no .fossil files there already - as it is probably a niche requirement - or a sign the user hasn't thought about a better/central location) + if {$startdir ni $usable_repo_folder_locations} { + lappend usable_repo_folder_locations $startdir + } + } + set choice_folders [list] + set i 1 + foreach fld $usable_repo_folder_locations { + set existing_fossils [glob -nocomplain -dir $fld -type f -tails *.fossil] + if {[set ecount [llength $existing_fossils]]} { + if {$ecount ==1} {set s ""} else {set s "s"} + set existingfossils "( $ecount existing .fossil$s )" + } else { + set existingfossils "( no existing .fossil files found )" + } + if {"$projectname.fossil" in $existing_fossils} { + set conflict "CONFLICT - $projectname.fossil already exists in this folder" + } else { + set conflict "" + } + lappend choice_folders [list index $i folder $fld folderexists 1 existingfossils $existingfossils conflict $conflict] + incr i + } + + if {![llength $choice_folders]} { + #no existing writable .fossil folders (and no existing .fossil files in startdir) + #offer the (writable) candidate_repo_folder_locations + foreach fld $candidate_repo_folder_locations { + lappend choice_folders [list index $i folder $fld folderexists 0 existingfossils "" conflict ""] + incr i + } + } + + set menu_message "" + if {[llength $choice_folders]} { + append menu_message "Select the number of the folder to use to store the .fossil repository file" \n + } else { + append menu_message "--- NO suitable writable folders or locations found for .fossil file. Consider setting FOSSIL_HOME environment variable and check that folders are writable.--" \n + } + + set conflicted_options [list] + foreach option $choice_folders { + set i [dict get $option index] ;# 1-based + set fld [dict get $option folder] + set existingfossils [dict get $option existingfossils] + set conflict [dict get $option conflict] + if {[string length $conflict]} { + lappend conflicted_options $i ;#1+ + } + set folderexists [dict get $option folderexists] + if {$folderexists} { + set folderstatus "(existing folder)" + } else { + set folderstatus "(CREATE folder for .fossil repository files)" + } + append menu_message "$i $folderstatus $fld $existingfossils $conflict" \n + } + + + #append the readonly_repo_folder_locations so that user is aware of them as it may affect their choice + if {[llength $readonly_repo_folder_locations]} { + append menu_message "--------------------------------------------------" \n + foreach readonly $readonly_repo_folder_locations { + append menu_message " $readonly" \n + } + append menu_message "--------------------------------------------------" \n + } + + #see if we can reasonably use the only available option and not bug the user + #Todo - option to always prompt? + #we will not auto-select if there is even one conflicted_option - as that seems like something you should know about + if {![llength $conflicted_options] && ([llength $choice_folders] == 1)} { + set repo_folder_choice [lindex $choice_folders 0] + set repository_folder [dict get $repo_folder_choice folder] + } else { + if {[llength $choice_folders]} { + puts stdout $menu_message + set max [llength $choice_folders] + if {$max == 1} { + set rangemsg "the number 1" + } else { + set rangemsg "a number from 1 to $max" + } + set answer [askuser "Enter $rangemsg to select location. (or N to abort)"] + if {![string is integer -strict $answer]} { + puts stderr "Aborting" + return + } + + set index [expr {int($answer) -1}] + if {$index >= 0 && $index <= $max-1} { + set repo_folder_choice [lindex $choice_folders $index] + set repository_folder [dict get $repo_folder_choice folder] + puts stdout "Selected fossil location $repository_folder" + } else { + puts stderr " No menu number matched - aborting." + return + } + } else { + puts stdout $menu_message + set answer [askuser "Hit enter to exit"] + return + } + } + return $repository_folder + } + + #------------------------------------ + #limit to exec so full punk shell not required in scripts + proc git_revision {{path {}}} { + if {$path eq {}} { set path [pwd] } + # ::kettle::path::revision.git + do_in_path $path { + try { + #git describe will error with 'No names found' if repo has no tags + #set v [::exec {*}[auto_execok git] describe] + set v [::exec {*}[auto_execok git] rev-parse HEAD] ;# consider 'git rev-parse --short HEAD' + } on error {e o} { + set v [lindex [split [dict get $o -errorinfo] \n] 0] + } + } + return [string trim $v] + } + proc git_remote {{path {{}}}} { + if {$path eq {}} { set path [pwd] } + do_in_path $path { + try { + #git describe will error with 'No names found' if repo has no tags + #set v [::exec {*}[auto_execok git] describe] + set v [::exec {*}[auto_execok git] -remote -v] ;# consider 'git rev-parse --short HEAD' + } on error {e o} { + set v [lindex [split [dict get $o -errorinfo] \n] 0] + } + } + return [string trim $v] + } + + proc fossil_revision {{path {}}} { + if {$path eq {}} { set path [pwd] } + # ::kettle::path::revision.fossil + set fossilcmd [auto_execok fossil] + if {[llength $fossilcmd]} { + do_in_path $path { + set info [::exec {*}$fossilcmd info] + } + return [lindex [grep {checkout:*} $info] 0 1] + } else { + return Unknown + } + } + + proc fossil_remote {{path {}}} { + if {$path eq {}} { set path [pwd] } + # ::kettle::path::revision.fossil + set fossilcmd [auto_execok fossil] + if {[llength $fossilcmd]} { + do_in_path $path { + set info [::exec {*}$fossilcmd remote ls] + } + return [string trim $info] + } else { + return Unknown + } + } + #------------------------------------ + + #temporarily cd to workpath to run script - return to correct path even on failure + proc do_in_path {path script} { + #from ::kettle::path::in + set here [pwd] + try { + cd $path + uplevel 1 $script + } finally { + cd $here + } + } + proc scanup {path cmd} { + if {$path eq {}} { set path [pwd] } + #based on kettle::path::scanup + if {[file pathtype $path] eq "relative"} { + set path [file normalize $path] + } + while {1} { + # Found the proper directory, per the predicate. + if {[{*}$cmd $path]} { return $path } + + # Not found, walk to parent + set new [file dirname $path] + + # Stop when reaching the root. + if {$new eq $path} { return {} } + if {$new eq {}} { return {} } + + # Ok, truly walk up. + set path $new + } + return {} + } + #get content part of content/zip delimited by special \x1a (ctrl-z) char as used in tarjr and kettle::path::c/z + proc c/z {content} { + return [lindex [split $content \x1A] 0] + } + proc grep {pattern data} { + set data [string map [list \r\n \n] $data] + return [lsearch -all -inline -glob [split $data \n] $pattern] + } + + proc rgrep {pattern data} { + set data [string map [list \r\n \n] $data] + return [lsearch -all -inline -regexp [split $data \n] $pattern] + } + + + #todo - review + proc ensure-cleanup {path} { + #::atexit [lambda {path} { + #file delete -force $path + #} [norm $path]] + + file delete -force $path + } + + + #whether path is at and/or below one of the vfs mount points + #The design should facilitate nested vfs mountpoints + proc path_vfs_info {filepath} { + error "unimplmented" + } + + #file normalize is expensive so this is too + proc norm {path {platform env}} { + #kettle::path::norm + #see also wiki + #full path normalization + + set platform [string tolower $platform] + if {$platform eq "env"} { + set platform $::tcl_platform(platform) + } + + #No - don't do this sort of path translation here - leave as option for specific utils only such as ./ + #Windows volume-relative syntax with specific volume specified is somewhat broken in Tcl - but leading slash volume-relative does work + #We shouldn't break it totally just because accessing WSL/mingw paths is slightly more useful + #if {$platform eq "windows"} { + #return [file dirname [file normalize [punk::unixywindows::towinpath $path]/__]] + #} + + return [file dirname [file normalize $path/__]] + } + + #This taken from kettle::path::strip + #It doesn't compare the prefix contents presumably for speed when used in kettle::path::scan + #renamed to better indicate its behaviour + + proc path_strip_prefixdepth {path prefix} { + if {$prefix eq ""} { + return [norm $path] + } + return [file join \ + {*}[lrange \ + [file split [norm $path]] \ + [llength [file split [norm $prefix]]] \ + end]] + } + + #Must accept empty prefix - which is effectively noop. + #MUCH faster version for absolute path prefix (pre-normalized) + proc path_strip_alreadynormalized_prefixdepth {path prefix} { + if {$prefix eq ""} { + return $path + } + return [file join \ + {*}[lrange \ + [file split $path] \ + [llength [file split $prefix]] \ + end]] + } + #fs agnostic - so file normalize must be done by caller + proc strip_if_prefix {prefix path args} { + set known_opts [list -nocase] + set opts [list] + foreach a $args { + lappend opts [tcl::prefix match -message "option" $known_opts $a] + } + if {"-nocase" in $opts} { + set lp [tcl::prefix longest [string tolower $path] [string tolower $prefix]] + } else { + set lp [tcl::prefix longest $path $prefix] + } + #return in original casing whether or not -nocase specified. -nocase only applies to the comparison + if {![llength $lp]} { + return $path + } else { + return [string range $path [string length $prefix] end] + } + } + + + interp alias {} is_fossil {} ::punk::repo::is_fossil + interp alias {} is_fossil_root {} ::punk::repo::is_fossil_root + interp alias {} find_fossil {} ::punk::repo::find_fossil + interp alias {} fossil_revision {} ::punk::repo::fossil_revision + interp alias {} is_git {} ::punk::repo::is_git + interp alias {} is_git_root {} ::punk::repo::is_git_root + interp alias {} find_git {} ::punk::repo::find_git + interp alias {} git_revision {} ::punk::repo::git_revision + + + interp alias {} gs {} git status -sb + interp alias {} gr {} ::punk::repo::git_revision + interp alias {} gl {} git log --oneline --decorate ;#decorate so stdout consistent with what we see on console + interp alias {} glast {} git log -1 HEAD --stat + interp alias {} gconf {} git config --global -l + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::repo [namespace eval punk::repo { + variable version + set version 0.1.1 +}] +return diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/winpath-0.1.0.tm b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/winpath-0.1.0.tm new file mode 100644 index 00000000..a21e91ef --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punk/winpath-0.1.0.tm @@ -0,0 +1,266 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application punk::winpath 0.1.0 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::winpath { + namespace export winpath windir cdwin cdwindir illegalname_fix illegalname_test + + + + + #\\servername\share etc or \\?\UNC\servername\share etc. + proc is_unc_path {path} { + set strcopy_path [punk::objclone $path] + set strcopy_path [string map [list \\ /] $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway) + if {[string first "//" $strcopy_path] == 0} { + #check for "Dos device path" syntax + if {[string range $strcopy_path 0 3] in [list "//?/" "//./"]} { + #Note that //./ doesn't appear to be supported in Tcl as at 2023-08 - but //?/ works (except for //?/UNC/Server/share) + if {[string range $strcopy_path 4 6] eq "UNC"} { + return 1 + } else { + #some other Dos device path. Could be a drive which is mapped to a UNC path - but the path itself isn't a unc path + return 0 + } + } else { + #leading double slash and not dos device path syntax + return 1 + } + } + return 0 + } + + #ordinary \\Servername or \\servername\share or \\servername\share\path (or forward-slash equivalent) with no dos device syntax //?/ //./ etc. + proc is_unc_path_plain {path} { + if {[is_unc_path $path]} { + if {![is_dos_device_path $path]} { + return 1 + } else { + return 0 + } + } else { + return 0 + } + } + + #int-rep path preserved - but 'file attributes', and therefor this operation, is expensive (on windows at least) + proc pwdshortname {{path {}}} { + if {$path eq ""} { + set path [pwd] + } else { + if {[file pathtype $path] eq "relative"} { + set path [file normalize $path] + } + } + return [dict get [file attributes $path] -shortname] + } + #dos device path syntax allows windows api to acces extended-length paths and filenames with illegal path characters such as trailing dots or whitespace + #(can exist on server shares and on NTFS - but standard apps can't access without dos device syntax) + proc is_dos_device_path {path} { + set strcopy_path [punk::objclone $path] + set strcopy_path [string map [list \\ /] $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway) + if {[string range $strcopy_path 0 3] in [list "//?/" "//./"]} { + return 1 + } else { + return 0 + } + } + proc strip_dos_device_prefix {path} { + #it's unlikely to be valid to strip only //?/ from a //?/UNC path so check for it here and diver to strip that. + #(review.. or raise error because a //?/UNC path isn't *strictly* a UNC path? ) + if {[is_unc_path $path]} { + return [strip_unc_path_prefix $path] + } + if {[is_dos_device_path $path]} { + return [string range $path 4 end] + } else { + return $path + } + } + proc strip_unc_path_prefix {path} { + if {[is_unc_path $path]} { + #//?/UNC/server/etc + set strcopy_path [punk::objclone $path] + set trimmedpath [string range $strcopy_path 7 end] + file pathtype $trimmedpath ;#shimmer it to path rep + return $trimmedpath + } elseif {is_unc_path_plain $path} { + #plain unc //server + set strcopy_path [punk::objclone $path] + set trimmedpath [string range $strcopy_path 2 end] + file pathtype $trimmedpath + return $trimmedpath + } else { + return $path + } + } + #we don't validate that path is actually illegal because we don't know the full range of such names. + #The caller can apply this to any path. + #don't test for platform here - needs to be callable from any platform for potential passing to windows (what usecase? 8.3 name is not always calculable independently) + #The utility of this is questionable. prepending a dos-device path won't make a filename with illegal characters readable by windows. + #It will need the 'shortname' at least for the illegal segment - if not the whole path + #Whilst the 8.3 name algorithm - including undocumented hash function has been reverse engineered + #- it depends on the content of the directory - as collisions cause a different name (e.g incremented number) + #- it also depends on the history of the folder + #- you can't take the current dir contents and a particular *existing* longname and determine the shortname algorithmically... + #- the shortname may have been generated during a different directory state. + #- It is then stored on disk (where?) - so access to reading the existing shortname is required. + #- An implementation of the 8.3 algorithm would only be potentially useful in determining the name that will result from adding a new file + # and would be subject to potential collisions if there are race-conditions in file creation + #- Using an 8.3 algorithm externally would be dangerous in that it could appear to work a lot of the time - but return a different file entirely sometimes. + #- Conclusion is that the 8.3 name must be retrieved rathern than calclated + proc illegalname_fix {path} { + #don't add extra dos device path syntax protection-prefix if already done + if {[is_unc_path $path]} { + error "illegalname_fix called on UNC path $path - unable to process" + } + if {[is_dos_device_path $path]} { + #we may have appended + return $path + } + + + + #\\servername\share theoretically maps to: \\?\UNC\servername\share in protected form. https://learn.microsoft.com/en-us/dotnet/standard/io/file-path-formats + #NOTE: 2023-08 on windows 10 at least \\?\UNC\Server\share doesn't work - ie we can't use illegalname_fix on UNC paths such as \\Server\share + #(but mapped drive to same path will work) + #Note that test-path cmdlet in powershell is also flaky with regards to \\?\UNC\Server paths. + #It seems prudent for now to disallow \\?\ protection for UNC paths such as \\server\etc + if {[is_unc_path $path]} { + set err "" + append err "illegalname_fix doesn't currently support UNC paths (non dos device leading double slash or //?/UNC/...)" + append err \n " - because //?/UNC/Servername/share is not supported in Tcl (and only minimally even in powershell) as at 2023. (on windows use mapped drive instead)" + error $err + } + + set strcopy_path [punk::objclone $path] + + + #Note: path could still have leading double slash if it is a Dos device path: e.g. //?/c:/etc + if {[file pathtype $path] eq "absolute"} { + if {$path eq "~"} { + # non-normalized ~ is classified as absolute + # tilde special meaning is a bit of a nuisance.. but as it's the entire path in this case.. presumably it should be kept that way + # leave for caller to interpret it - but it's not an illegal name whether it's interpreted with special meaning or not + # unlikely this fix will be called on a plain tilde anyway + return $path + } else { + set fullpath $path + } + } else { + #set fullpath [file normalize $path] ;#very slow on windows + #set fullpath [pwd]/$path ;#will keep ./ in middle of path - not valid for dos-device paths + if {[string range $strcopy_path 0 1] eq "./"} { + set strcopy_path [string range $strcopy_path 2 end] + } + set fullpath [file join [pwd] $strcopy_path] + } + #For file I/O, the "\\?\" prefix to a path string tells the Windows APIs to disable all string parsing + # and to send the string that follows it straight to the file system. + set protect "\\\\?\\" ;# value is: \\?\ prefix + set protect2 "//?/" ;#file normalize may do this - it still works + #don't use "//./" - not currently supported in Tcl - seems to work in powershell though. + + + #choose //?/ as normalized version - since likely 'file normalize' will do it anyway, and experimentall, the windows API accepts both REVIEW + set result ${protect2}$fullpath + file pathtype $result ;#make it return a path rep + return $result + } + + #don't test for platform here - needs to be callable from any platform for potential passing to windows + #we can create files with windows illegal names by using //?/ dos device path syntax - but we need to detect when that is required. + # + # path int-rep preserving + proc illegalname_test {path} { + #https://learn.microsoft.com/en-us/windows/win32/fileio/naming-a-file + #according to the above: Use any character in the current code page for a name, including Unicode characters and characters in the extended character set (128–255), except for the following: + set reserved [list < > : \" / \\ | ? *] + + + #we need to exclude things like path/.. path/. + foreach seg [file split $path] { + if {$seg in [list . ..]} { + #review - what if there is a folder or file that actually has a name such as . or .. ? + #unlikely in normal use - but could done deliberately for bad reasons? + #We are unable to check for it here anyway - as this command is intended for checking the path string - not the actual path on a filesystem. + # + #/./ /../ segments don't require protection - keep checking. + continue + } + + #only check for actual space as other whitespace seems to work without being stripped + #trailing tab and trailing \n or \r seem to be creatable in windows with Tcl - map to some glyph + if {[string index $seg end] in [list " " "."]} { + #windows API doesn't handle trailing dots or spaces (silently strips) - even though such files can be created on NTFS systems (or seen via samba etc) + return 1 + } + } + #glob chars '* ?' are probably illegal.. but although x*y.txt and x?y.txt don't display properly (* ? replaced with some other glyph) + #- they seem to be readable from cmd and tclsh as is. + # pipe symbol also has glyph substitution and behaves the same e.g a|b.txt + #(at least with encoding system utf-8) + + #todo - determine what else constitutes an illegal name according to windows APIs and requires protection with dos device syntax + return 0 + } + + proc test_ntfs_tunneling {f1 f2 args} { + file mkdir $f1 + puts stderr "waiting 15secs..." + after 5000 {puts -nonewline stderr .} + after 5000 {puts -nonewline stderr .} + after 5000 {puts -nonewline stderr .} + after 500 {puts stderr \n} + file mkdir $f2 + puts stdout "$f1 [file stat $f1]" + puts stdout "$f2 [file stat $f2]" + file delete $f1 + puts stdout "renaming $f2 to $f1" + file rename $f2 $f1 + puts stdout "$f1 [file stat $f1]" + + } + +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::winpath [namespace eval punk::winpath { + variable version + set version 0.1.0 +}] +return diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punkcheck-0.1.0.tm b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punkcheck-0.1.0.tm index a65e1f7a..41d8759a 100644 --- a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punkcheck-0.1.0.tm +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punkcheck-0.1.0.tm @@ -234,10 +234,12 @@ namespace eval punkcheck { #related - installfile_begin #call init before we know if we are going to run the operation vs skip method targetset_init {operation targetset} { - set known_ops [list INSTALL MODIFY DELETE VIRTUAL] + set known_ops [list QUERY INSTALL MODIFY DELETE VIRTUAL] if {[string toupper $operation] ni $known_ops} { error "[self] add_target unknown operation '$operation'. Known operations $known_ops" } + set o_operation [string toupper $operation] + if {$o_operation_start_ts ne ""} { error "[self] targetset_tart $o_operation operation already in progress. Use targetset_finished or targetset_complete to finish." } @@ -245,18 +247,24 @@ namespace eval punkcheck { set seconds [expr {$o_operation_start_ts / 1000000}] set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] set relativepath_targetset [list] - foreach p $targetset { - if {[file pathtype $p] eq "absolute"} { - lappend relativepath_targetset [punkcheck::lib::path_relative [file dirname $punkcheck_file] $p] - } else { + if {$o_operation eq "VIRTUAL"} { + foreach p $targetset { lappend relativepath_targetset $p } + } else { + foreach p $targetset { + if {[file pathtype $p] eq "absolute"} { + lappend relativepath_targetset [punkcheck::lib::path_relative $punkcheck_folder $p] + } else { + lappend relativepath_targetset $p + } + } } - set o_operation $operation set fields [list\ -tsiso $tsiso\ -ts $o_operation_start_ts\ @@ -280,7 +288,7 @@ namespace eval punkcheck { #-installer and -eventid keys are added here set new_inprogress_record [dict create tag [string toupper $operation]-INPROGRESS {*}$fields -tempcontext [my as_record] body {}] #set existing_body [dict_getwithdefault $o_fileset_record body [list]] - #todo - look for existing "-INPROGRESS" records - mark as failed? + #todo - look for existing "-INPROGRESS" records - mark as failed or incomplete? dict lappend o_fileset_record body $new_inprogress_record if {$isnew} { @@ -288,15 +296,36 @@ namespace eval punkcheck { } else { set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record] } - - punkcheck::save_records_to_file $record_list $punkcheck_file + if {$o_operation ne "QUERY"} { + punkcheck::save_records_to_file $record_list $punkcheck_file + } return $o_fileset_record } #operation has been started + #todo - upgrade .punkcheck format to hold more than just list of SOURCE entries in each record. + # - allow arbitrary targetset_startphase targetset_endphase calls to store timestamps and calculate elapsed time method targetset_started {} { set punkcheck_folder [file dirname [$o_installer get_checkfile]] - set o_fileset_record [punkcheck::installfile_started_install $punkcheck_folder $o_fileset_record] + if {$o_operation eq "QUERY"} { + set fileinfo_body [dict get $o_fileset_record body] ;#body of FILEINFO record + set installing_record [lindex $fileinfo_body end] + + set ts_start [dict get $installing_record -ts] + set ts_now [clock microseconds] + set metadata_us [expr {$ts_now - $ts_start}] + + dict set installing_record -metadata_us $metadata_us + dict set installing_record -ts_start_transfer $ts_now + + lset fileinfo_body end $installing_record + + return [dict set o_fileset_record body $fileinfo_body] + } else { + #legacy call + #saves to .punkcheck file + return [set o_fileset_record [punkcheck::installfile_started_install $punkcheck_folder $o_fileset_record]] + } } method targetset_end {status args} { set defaults [dict create\ @@ -311,7 +340,6 @@ namespace eval punkcheck { dict unset opts -note } - set status [string toupper $status] set statusdict [dict create OK RECORD SKIPPED SKIPPED FAILED FAILED] if {$o_operation_start_ts eq ""} { @@ -332,6 +360,7 @@ namespace eval punkcheck { set file_record_body [dict get $o_fileset_record body] set installing_record [lindex $file_record_body end] set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] set record_list [punkcheck::load_records_from_file $punkcheck_file] if {[dict exists $installing_record -ts_start_transfer]} { set ts_start_transfer [dict get $installing_record -ts_start_transfer] @@ -345,6 +374,23 @@ namespace eval punkcheck { dict set installing_record -elapsed_us $elapsed_us dict unset installing_record -tempcontext dict set installing_record tag "${o_operation}-[dict get $statusdict $status]" ;# e.g INSTALL-RECORD, INSTALL-SKIPPED + if {$o_operation in [list INSTALL MODIFY] && [dict get $statusdict $status] eq "RECORD"} { + #only calculate and store post operation target cksums on successful INSTALL or MODIFY, doesn't make sense for DELETE or VIRTUAL operations + set new_targets_cksums [list] ;#ordered list of cksums matching targetset order + set cksum_all_opts "" ;#same cksum opts for each target so we store it once + set ts_begin_cksum [clock microseconds] + foreach p $o_targets { + set tgt_cksum_info [punk::mix::base::lib::cksum_path [file join $punkcheck_folder $p]] + lappend new_targets_cksums [dict get $tgt_cksum_info cksum] + if {$cksum_all_opts eq ""} { + set cksum_all_opts [dict get $tgt_cksum_info opts] + } + } + set cksum_us [expr {[clock microseconds] - $ts_begin_cksum}] + dict set installing_record -targets_cksums $new_targets_cksums + dict set installing_record -cksum_all_opts $cksum_all_opts + dict set installing_record -cksum_us $cksum_us + } lset file_record_body end $installing_record dict set o_fileset_record body $file_record_body set o_fileset_record [punkcheck::recordlist::file_record_prune $o_fileset_record] @@ -356,7 +402,9 @@ namespace eval punkcheck { } else { lset record_list $old_posn $o_fileset_record } - punkcheck::save_records_to_file $record_list $punkcheck_file + if {$o_operation ne "QUERY"} { + punkcheck::save_records_to_file $record_list $punkcheck_file + } set o_operation_start_ts "" set o_operation "" return $o_fileset_record @@ -372,6 +420,20 @@ namespace eval punkcheck { set o_fileset_record [punkcheck::installfile_add_source_and_fetch_metadata $punkcheck_folder $rel_source_path $o_fileset_record] + } + method targetset_last_complete {} { + #retrieve last completed record for the fileset ie exclude SKIPPED,INSTALL-INPROGRESS,DELETE-INPROGRESS,MODIFY-INPROGRESS + set body [punkcheck::dict_getwithdefault $o_fileset_record body [list]] + set previous_records [lrange $body 0 end] + #get last that is tagged INSTALL-RECORD,MODIFY-RECORD,DELETE-RECORD + set revlist [lreverse $previous_records] + foreach rec $revlist { + if {[dict get $rec tag] in [list "INSTALL-RECORD" "MODIFY-RECORD" "DELETE-RECORD" "VIRTUAL-RECORD"]} { + return $rec + } + } + return [list] + } method targetset_source_changes {} { punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $o_fileset_record body] end] @@ -551,16 +613,6 @@ namespace eval punkcheck { method get_event {} { return $o_active_event } - if 0 { - method unknown {args} { - puts "[self] unknown called with args:$args" - if {[llength $args]} { - - } else { - - } - } - } } } proc start_installer_event {punkcheck_file installername from_fullpath to_fullpath config} { @@ -722,6 +774,10 @@ namespace eval punkcheck { } else { set cksum_opts "" } + + #todo - accept argument of cached source cksum info (for client calling multiple targets with same source in quick succession e.g when building .vfs kits with multiple runtimes) + #if same cksum_opts - then use cached data instead of checksumming here. + #allow nonexistant as a source set fpath [file join $punkcheck_folder $source_relpath] if {![file exists $fpath]} { @@ -857,7 +913,7 @@ namespace eval punkcheck { set tsnow [clock microseconds] set elapsed_us [expr {$tsnow - $ts_start}] dict set installing_record -elapsed_us $elapsed_us - dict set installing_record tag "SKIPPED" + dict set installing_record tag "INSTALL-SKIPPED" lset file_record_body end $installing_record dict set file_record body $file_record_body @@ -879,13 +935,14 @@ namespace eval punkcheck { #then: file_record_add_installrecord namespace eval lib { + set pkg punkcheck namespace path ::punkcheck proc is_file_record_inprogress {file_record} { if {[dict get $file_record tag] ne "FILEINFO"} { return 0 } set installing_record [lindex [dict_getwithdefault $file_record body [list]] end] - if {[dict_getwithdefault $installing_record tag [list]] ni [list INSTALL-INPROGRESS MODIFY-INPROGRESS DELETE-INPROGRESS VIRTUAL-INPROGRESS]} { + if {[dict_getwithdefault $installing_record tag [list]] ni [list QUERY-INPROGRESS INSTALL-INPROGRESS MODIFY-INPROGRESS DELETE-INPROGRESS VIRTUAL-INPROGRESS]} { return 0 } return 1 @@ -1021,9 +1078,16 @@ namespace eval punkcheck { } proc install_non_tm_files {srcdir basedir args} { #set keys [dict keys $args] + #adjust the default anti_glob_dir_core entries so that .fossil-custom, .fossil-settings are copied + set antiglob_dir_core [punkcheck::default_antiglob_dir_core] + set posn [lsearch $antiglob_dir_core ".fossil*"] + if {$posn >=0} { + set antiglob_dir_core [lreplace $antiglob_dir_core $posn $posn] + } set defaults [list\ -glob *\ -antiglob_file [list "*.tm" "*-buildversion.txt" "*.exe"]\ + -antiglob_dir_core $antiglob_dir_core\ -installer punkcheck::install_non_tm_files\ ] set opts [dict merge $defaults $args] @@ -1070,7 +1134,8 @@ namespace eval punkcheck { # -overwrite newer-targets will copy files with older source timestamp over newer target timestamp and those missing at the target (a form of 'restore' operation) # -overwrite older-targets will copy files with newer source timestamp over older target timestamp and those missing at the target # -overwrite all-targets will copy regardless of timestamp at target - # -overwrite installedsourcechanged-targets + # -overwrite installedsourcechanged-targets will copy if the target doesn't exist or the source changed + # -overwrite synced-targets will copy if the target doesn't exist or the source changed and the target cksum is the same as the last INSTALL-RECORD targets_cksums entry # review - timestamps unreliable # - what about slightly mismatched system clocks and mounted filesystems? caller responsibility to verify first? # if timestamp exactly equal - should we check content-hash? This is presumably only likely to occur deliberately(maliciously?) @@ -1091,11 +1156,13 @@ namespace eval punkcheck { # -source_checksum compare|store|comparestore|false|true where true == comparestore # -punkcheck_folder target|source|project| target is default and is generally recommended # -punkcheck_records empty string | parsed TDL records ie {tag xxx k v} structure + # install creates FILEINFO records with a single entry in the -targets field (it is legitimate to have a list of targets for an installation operation - the oo interface supports this) proc install {srcdir tgtdir args} { set defaults [list\ -call-depth-internal 0\ -max_depth 1000\ -subdirlist {}\ + -createdir 0\ -glob *\ -antiglob_file_core "\uFFFF"\ -antiglob_file "" \ @@ -1130,11 +1197,15 @@ namespace eval punkcheck { set max_depth [dict get $opts -max_depth] set subdirlist [dict get $opts -subdirlist] ;# generally should be same length as CALLDEPTH - but user could prefill set fileglob [dict get $opts -glob] + set createdir [dict get $opts -createdir] ;#defaults to zero to help avoid mistakes with initial target dir - required target subdirs are created regardless of this setting if {$CALLDEPTH == 0} { #expensive to normalize but we need to do it at least once set srcdir [file normalize $srcdir] set tgtdir [file normalize $tgtdir] + if {$createdir} { + file mkdir $tgtdir + } #now the values we build from these will be properly cased } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -1157,7 +1228,7 @@ namespace eval punkcheck { set opt_unpublish_paths [dict get $opts -unpublish_paths] ;#todo - combine with config file in source tree .punkcheckpublish (?) set unpublish_paths_matched [list] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - set known_whats [list no-targets newer-targets older-targets all-targets installedsourcechanged-targets] + set known_whats [list no-targets newer-targets older-targets all-targets installedsourcechanged-targets synced-targets] set overwrite_what [string tolower [dict get $opts -overwrite]]; #accept any case for value to allow emphasis by caller e.g -overwrite NEWER-TARGETS if {$overwrite_what ni $known_whats} { error "punkcheck::install received unrecognised value for -overwrite. Received value '$overwrite_what' vs known values '$known_whats'" @@ -1246,9 +1317,9 @@ namespace eval punkcheck { } if {[string match *store* $opt_source_checksum]} { - set store_cksums 1 + set store_source_cksums 1 } else { - set store_cksums 0 + set store_source_cksums 0 } @@ -1280,7 +1351,7 @@ namespace eval punkcheck { #puts "testing folder - globmatchpath $unpub $relative_source_dir" if {[globmatchpath $unpub $relative_source_dir]} { lappend unpublish_paths_matched $current_source_dir - return [list files_copied {} files_skipped {} sources_unchanged {} punkcheck_records $punkcheck_records unpublish_paths_matched $unpublish_paths_matched] + return [list files_copied {} files_skipped {} sources_unchanged {} punkcheck_records $punkcheck_records unpublish_paths_matched $unpublish_paths_matched srcdir $srcdir tgtdir $tgtdir punkcheck_folder $punkcheck_folder] } } @@ -1343,6 +1414,7 @@ namespace eval punkcheck { #puts stdout "Current target dir: $current_target_dir" foreach m $match_list { + set new_tgt_cksum_info [list] set relative_target_path [file join $relative_target_dir $m] set relative_source_path [file join $relative_source_dir $m] set punkcheck_target_relpath [file join $target_relative_to_punkcheck_dir $m] @@ -1400,10 +1472,14 @@ namespace eval punkcheck { #this hits the filesystem for the sourcepath - gets checksums/timestamps depending on config. #It doesn't save to .punkcheck (the only punkcheck::installfile_ method which doesn't) set filerec [punkcheck::installfile_add_source_and_fetch_metadata $punkcheck_folder $relative_source_path $filerec] - + + + + #changeinfo comes from last record in body - which is the record we are working on and so will always exist set changeinfo [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $filerec body] end]] set changed [dict get $changeinfo changed] set unchanged [dict get $changeinfo unchanged] + if {[llength $unchanged]} { lappend sources_unchanged $current_source_dir/$m } @@ -1415,6 +1491,7 @@ namespace eval punkcheck { } else { if {![file exists $current_target_dir/$m]} { file copy $current_source_dir/$m $current_target_dir + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] lappend files_copied $current_source_dir/$m incr filecount_new } else { @@ -1422,15 +1499,48 @@ namespace eval punkcheck { if {[llength $changed]} { #An unrecorded installation is considered a source change (from unknown/unrecorded source to recorded) file copy -force $current_source_dir/$m $current_target_dir + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] lappend files_copied $current_source_dir/$m } else { set is_skip 1 lappend files_skipped $current_source_dir/$m } + } elseif {$overwrite_what eq "synced-targets"} { + if {[llength $changed]} { + #only overwrite if the target checksum equals the last installed checksum (ie target is in sync with source and so hasn't been customized) + set existing_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + set is_target_unmodified_since_install 0 + set target_cksum_compare "unknown" + set latest_install_record [punkcheck::recordlist::file_record_latest_installrecord $filerec] ;#may be no such record - in which case we get an empty list + if {[dict exists $latest_install_record -targets_cksums]} { + set last_install_cksum [dict get $latest_install_record -targets_cksums] ;#in this case we know there is only one as 'install' always uses targetset size of 1. (FILEINFO record per file in source folder) + if {[dict get $existing_tgt_cksum_info cksum] eq $last_install_cksum} { + set is_target_unmodified_since_install 1 + set target_cksum_compare "match" + } else { + set target_cksum_compare "nomatch" + } + } else { + set target_cksum_compare "norecord" + } + if {$is_target_unmodified_since_install} { + file copy -force $current_source_dir/$m $current_target_dir + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + lappend files_copied $current_source_dir/$m + } else { + #either cksum is different or we were unable to verify the record. Either way we can't know if the target is in sync so we must skip it + set is_skip 1 + puts stderr "Skipping file copy $m target $current_target_dir/$m - require synced_target to overwrite - current target cksum compared to previous install: $target_cksum_compare" + lappend files_skipped $current_source_dir/$m + } + } else { + set is_skip 1 + lappend files_skipped $current_source_dir/$m + } } else { set is_skip 1 puts stderr "Skipping file copy $m target $current_target_dir/$m already exists (use -overwrite all-targets to overwrite)" - #TODO! implement newer-targets older-targets + #TODO! implement newer-targets older-targets? (note ctimes/mtimes are unreliable - may not be worth implementing) lappend files_skipped $current_source_dir/$m } } @@ -1440,27 +1550,31 @@ namespace eval punkcheck { set ts_now [clock microseconds] set elapsed_us [expr {$ts_now - $ts_start}] - if {$store_cksums} { + #if {$store_source_cksums} { + #} - set install_records [dict get $filerec body] - set current_install_record [lindex $install_records end] - #change the tag from *-INPROGRESS to INSTALL-RECORD/SKIPPED - if {$is_skip} { - set tag INSTALL-SKIPPED - } else { - set tag INSTALL-RECORD - } - dict set current_install_record tag $tag - dict set current_install_record -elapsed_us $elapsed_us - lset install_records end $current_install_record - dict set filerec body $install_records - set filerec [punkcheck::recordlist::file_record_prune $filerec] ;#prune now that tag is finalized - if {!$has_filerec} { - #not found in original recordlist - append - lappend punkcheck_records $filerec - } else { - lset punkcheck_records $existing_filerec_posn $filerec - } + set install_records [dict get $filerec body] + set current_install_record [lindex $install_records end] + #change the tag from *-INPROGRESS to INSTALL-RECORD/SKIPPED + if {$is_skip} { + set tag INSTALL-SKIPPED + } else { + set tag INSTALL-RECORD + } + dict set current_install_record tag $tag + dict set current_install_record -elapsed_us $elapsed_us + if {[llength $new_tgt_cksum_info]} { + dict set current_install_record -targets_cksums [list [dict get $new_tgt_cksum_info cksum]] + dict set current_install_record -cksum_all_opts [dict get $new_tgt_cksum_info opts] + } + lset install_records end $current_install_record + dict set filerec body $install_records + set filerec [punkcheck::recordlist::file_record_prune $filerec] ;#prune now that tag is finalized + if {!$has_filerec} { + #not found in original recordlist - append + lappend punkcheck_records $filerec + } else { + lset punkcheck_records $existing_filerec_posn $filerec } } @@ -1536,11 +1650,10 @@ namespace eval punkcheck { #puts "subdirlist: $subdirlist" if {$CALLDEPTH == 0} { if {[llength $files_copied] || [llength $files_skipped]} { - puts stdout ">>>>>>>>>>>>>>>>>>>" + #puts stdout ">>>>>>>>>>>>>>>>>>>" set saveresult [punkcheck::save_records_to_file $punkcheck_records $punkcheck_file] - puts stdout "[dict get $saveresult recordcount] records saved as [dict get $saveresult linecount] lines to $punkcheck_file" - puts stdout "copied: [llength $files_copied] skipped: [llength $files_skipped]" - puts stdout ">>>>>>>>>>>>>>>>>>>" + puts stdout "punkcheck::install [dict get $saveresult recordcount] records saved as [dict get $saveresult linecount] lines to $punkcheck_file copied: [llength $files_copied] skipped: [llength $files_skipped]" + #puts stdout ">>>>>>>>>>>>>>>>>>>" } else { #todo - write db INSTALLER record if -debug true @@ -1551,10 +1664,30 @@ namespace eval punkcheck { } } - return [list files_copied $files_copied files_skipped $files_skipped sources_unchanged $sources_unchanged unpublish_paths_matched $unpublish_paths_matched punkcheck_records $punkcheck_records] + return [list files_copied $files_copied files_skipped $files_skipped sources_unchanged $sources_unchanged unpublish_paths_matched $unpublish_paths_matched punkcheck_records $punkcheck_records punkcheck_folder $punkcheck_folder srcdir $srcdir tgtdir $tgtdir] + } + proc summarize_install_resultdict {resultdict} { + set msg "" + if {[dict size $resultdict]} { + set copied [dict get $resultdict files_copied] + append msg "--------------------------" \n + append msg "[dict keys $resultdict]" \n + set tgtdir [dict get $resultdict tgtdir] + set checkfolder [dict get $resultdict punkcheck_folder] + append msg "Copied [llength $copied] files from [dict get $resultdict srcdir] to [dict get $resultdict tgtdir]" \n + foreach f $copied { + append msg "COPIED [punkcheck::lib::path_relative $checkfolder $f]" \n + append msg " TO $tgtdir" \n + } + append msg "[llength [dict get $resultdict sources_unchanged]] unchanged source files" \n + append msg "[llength [dict get $resultdict files_skipped]] skipped files" \n + append msg "--------------------------" \n + } + return $msg } namespace eval recordlist { + set pkg punkcheck namespace path ::punkcheck proc records_as_target_dict {record_list} { @@ -1590,8 +1723,8 @@ namespace eval punkcheck { } proc file_install_record_source_changes {install_record} { #reject INSTALLFAILED items ? - if {[dict get $install_record tag] ni [list "INSTALL-RECORD" "SKIPPED" "INSTALL-INPROGRESS" "MODIFY-INPROGRESS" "MODIFY-RECORD" "VIRTUAL-INPROGRESS" "VIRTUAL-RECORD" "DELETE-RECORD" "DELETE-INPROGRESS"]} { - error "file_install_record_source_changes bad file->install record: tag not INSTALL-RECORD|SKIPPED|INSTALL-INPROGRESS|MODIFY-RECORD|MODIFY-INPROGRESS|VIRTUAL-RECORD|VIRTUAL-INPROGRESS|DELETE-RECORD|DELETE-INPROGRESS" + if {[dict get $install_record tag] ni [list "QUERY-INPROGRESS" "INSTALL-RECORD" "INSTALL-SKIPPED" "INSTALL-INPROGRESS" "MODIFY-INPROGRESS" "MODIFY-RECORD" "MODIFY-SKIPPED" "VIRTUAL-INPROGRESS" "VIRTUAL-RECORD" "VIRTUAL-SKIPPED" "DELETE-RECORD" "DELETE-INPROGRESS" "DELETE-SKIPPED"]} { + error "file_install_record_source_changes bad install record: tag '[dict get $install_record tag]' not INSTALL-RECORD|SKIPPED|INSTALL-INPROGRESS|MODIFY-RECORD|MODIFY-INPROGRESS|VIRTUAL-RECORD|VIRTUAL-INPROGRESS|DELETE-RECORD|DELETE-INPROGRESS" } set source_list [dict_getwithdefault $install_record body [list]] set changed [list] @@ -1742,15 +1875,19 @@ namespace eval punkcheck { return $installer_record } proc file_record_latest_installrecord {file_record} { + tailcall file_record_latest_operationrecord INSTALL $file_record + } + proc file_record_latest_operationrecord {operation file_record} { + set operation [string toupper $operation] if {[dict get $file_record tag] ne "FILEINFO"} { - error "file_record_latest_installrecord bad file_record: tag not FILEINFO" + error "file_record_latest_operationrecord bad file_record: tag not FILEINFO" } if {![dict exists $file_record body]} { return [list] } set body_items [dict get $file_record body] foreach item [lreverse $body_items] { - if {[dict get $item tag] eq "INSTALL-RECORD"} { + if {[dict get $item tag] eq "$operation-RECORD"} { return $item } } @@ -1758,47 +1895,6 @@ namespace eval punkcheck { } - #dead code? - proc file_record_add_installrecordXXX {file_record install_record} { - if {[dict get $file_record tag] ne "FILEINFO"} { - error "file_record_add_installrecord bad file_record: tag not FILEINFO" - } - #disallow '-INPROGRESS' as it's not a final tag - if {[dict get $install_record tag] ni [list "INSTALL-RECORD" "SKIPPED"]} { - error "file_record_add_installrecord bad install_record: tag not INSTALL-RECORD" - } - set keep 3 - if {[dict exists $file_record -keep_installrecords]} { - set keep [dict get $file_record -keep_installrecords] - } - - if {[dict exists $file_record body]} { - set body_items [dict get $file_record body] - } else { - set body_items [list] - } - lappend body_items $install_record - set kept_body_items [list] - set kcount 0 - foreach item [lreverse $body_items] { - if {[dict get $item tag] eq "INSTALL-RECORD"} { - incr kcount - if {$keep < 0 || $kcount <= $keep} { - lappend kept_body_items $item - } - } else { - lappend kept_body_items $item - } - } - set kept_body_items [lreverse $kept_body_items] - - dict set file_record body $kept_body_items - return $file_record - - - } - - proc file_record_set_defaults {file_record} { if {[dict get $file_record tag] ne "FILEINFO"} { error "file_record_set_defaults bad file_record: tag not FILEINFO" @@ -1881,6 +1977,7 @@ namespace eval punkcheck { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready package provide punkcheck [namespace eval punkcheck { + set pkg punkcheck variable version set version 0.1.0 }] diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/struct/set-2.2.3.tm b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/struct/set-2.2.3.tm new file mode 100644 index 00000000..2ed2c260 --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/struct/set-2.2.3.tm @@ -0,0 +1,189 @@ +#---------------------------------------------------------------------- +# +# sets.tcl -- +# +# Definitions for the processing of sets. +# +# Copyright (c) 2004-2008 by Andreas Kupries. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: sets.tcl,v 1.17 2008/03/09 04:24:37 andreas_kupries Exp $ +# +#---------------------------------------------------------------------- + +# @mdgen EXCLUDE: sets_c.tcl + +package require Tcl 8.5- + +namespace eval ::struct::set {} + +# ### ### ### ######### ######### ######### +## Management of set implementations. + +# ::struct::set::LoadAccelerator -- +# +# Loads a named implementation, if possible. +# +# Arguments: +# key Name of the implementation to load. +# +# Results: +# A boolean flag. True if the implementation +# was successfully loaded; and False otherwise. + +proc ::struct::set::LoadAccelerator {key} { + variable accel + set r 0 + switch -exact -- $key { + critcl { + # Critcl implementation of set requires Tcl 8.4. + if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} + if {[catch {package require tcllibc}]} {return 0} + set r [llength [info commands ::struct::set_critcl]] + } + tcl { + variable selfdir + source [file join $selfdir sets_tcl.tcl] + set r 1 + } + default { + return -code error "invalid accelerator/impl. package $key:\ + must be one of [join [KnownImplementations] {, }]" + } + } + set accel($key) $r + return $r +} + +# ::struct::set::SwitchTo -- +# +# Activates a loaded named implementation. +# +# Arguments: +# key Name of the implementation to activate. +# +# Results: +# None. + +proc ::struct::set::SwitchTo {key} { + variable accel + variable loaded + + if {[string equal $key $loaded]} { + # No change, nothing to do. + return + } elseif {![string equal $key ""]} { + # Validate the target implementation of the switch. + + if {![info exists accel($key)]} { + return -code error "Unable to activate unknown implementation \"$key\"" + } elseif {![info exists accel($key)] || !$accel($key)} { + return -code error "Unable to activate missing implementation \"$key\"" + } + } + + # Deactivate the previous implementation, if there was any. + + if {![string equal $loaded ""]} { + rename ::struct::set ::struct::set_$loaded + } + + # Activate the new implementation, if there is any. + + if {![string equal $key ""]} { + rename ::struct::set_$key ::struct::set + } + + # Remember the active implementation, for deactivation by future + # switches. + + set loaded $key + return +} + +proc ::struct::set::Loaded {} { + variable loaded + return $loaded +} + +# ::struct::set::Implementations -- +# +# Determines which implementations are +# present, i.e. loaded. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. + +proc ::struct::set::Implementations {} { + variable accel + set res {} + foreach n [array names accel] { + if {!$accel($n)} continue + lappend res $n + } + return $res +} + +# ::struct::set::KnownImplementations -- +# +# Determines which implementations are known +# as possible implementations. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. In the order +# of preference, most prefered first. + +proc ::struct::set::KnownImplementations {} { + return {critcl tcl} +} + +proc ::struct::set::Names {} { + return { + critcl {tcllibc based} + tcl {pure Tcl} + } +} + +# ### ### ### ######### ######### ######### +## Initialization: Data structures. + +namespace eval ::struct::set { + variable selfdir [file dirname [info script]] + variable accel + array set accel {tcl 0 critcl 0} + variable loaded {} +} + +# ### ### ### ######### ######### ######### +## Initialization: Choose an implementation, +## most prefered first. Loads only one of the +## possible implementations. And activates it. + +namespace eval ::struct::set { + variable e + foreach e [KnownImplementations] { + if {[LoadAccelerator $e]} { + SwitchTo $e + break + } + } + unset e +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Export the constructor command. + namespace export set +} + +package provide struct::set 2.2.3 diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/struct/sets.tcl b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/struct/sets.tcl new file mode 100644 index 00000000..2ed2c260 --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/struct/sets.tcl @@ -0,0 +1,189 @@ +#---------------------------------------------------------------------- +# +# sets.tcl -- +# +# Definitions for the processing of sets. +# +# Copyright (c) 2004-2008 by Andreas Kupries. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: sets.tcl,v 1.17 2008/03/09 04:24:37 andreas_kupries Exp $ +# +#---------------------------------------------------------------------- + +# @mdgen EXCLUDE: sets_c.tcl + +package require Tcl 8.5- + +namespace eval ::struct::set {} + +# ### ### ### ######### ######### ######### +## Management of set implementations. + +# ::struct::set::LoadAccelerator -- +# +# Loads a named implementation, if possible. +# +# Arguments: +# key Name of the implementation to load. +# +# Results: +# A boolean flag. True if the implementation +# was successfully loaded; and False otherwise. + +proc ::struct::set::LoadAccelerator {key} { + variable accel + set r 0 + switch -exact -- $key { + critcl { + # Critcl implementation of set requires Tcl 8.4. + if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} + if {[catch {package require tcllibc}]} {return 0} + set r [llength [info commands ::struct::set_critcl]] + } + tcl { + variable selfdir + source [file join $selfdir sets_tcl.tcl] + set r 1 + } + default { + return -code error "invalid accelerator/impl. package $key:\ + must be one of [join [KnownImplementations] {, }]" + } + } + set accel($key) $r + return $r +} + +# ::struct::set::SwitchTo -- +# +# Activates a loaded named implementation. +# +# Arguments: +# key Name of the implementation to activate. +# +# Results: +# None. + +proc ::struct::set::SwitchTo {key} { + variable accel + variable loaded + + if {[string equal $key $loaded]} { + # No change, nothing to do. + return + } elseif {![string equal $key ""]} { + # Validate the target implementation of the switch. + + if {![info exists accel($key)]} { + return -code error "Unable to activate unknown implementation \"$key\"" + } elseif {![info exists accel($key)] || !$accel($key)} { + return -code error "Unable to activate missing implementation \"$key\"" + } + } + + # Deactivate the previous implementation, if there was any. + + if {![string equal $loaded ""]} { + rename ::struct::set ::struct::set_$loaded + } + + # Activate the new implementation, if there is any. + + if {![string equal $key ""]} { + rename ::struct::set_$key ::struct::set + } + + # Remember the active implementation, for deactivation by future + # switches. + + set loaded $key + return +} + +proc ::struct::set::Loaded {} { + variable loaded + return $loaded +} + +# ::struct::set::Implementations -- +# +# Determines which implementations are +# present, i.e. loaded. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. + +proc ::struct::set::Implementations {} { + variable accel + set res {} + foreach n [array names accel] { + if {!$accel($n)} continue + lappend res $n + } + return $res +} + +# ::struct::set::KnownImplementations -- +# +# Determines which implementations are known +# as possible implementations. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. In the order +# of preference, most prefered first. + +proc ::struct::set::KnownImplementations {} { + return {critcl tcl} +} + +proc ::struct::set::Names {} { + return { + critcl {tcllibc based} + tcl {pure Tcl} + } +} + +# ### ### ### ######### ######### ######### +## Initialization: Data structures. + +namespace eval ::struct::set { + variable selfdir [file dirname [info script]] + variable accel + array set accel {tcl 0 critcl 0} + variable loaded {} +} + +# ### ### ### ######### ######### ######### +## Initialization: Choose an implementation, +## most prefered first. Loads only one of the +## possible implementations. And activates it. + +namespace eval ::struct::set { + variable e + foreach e [KnownImplementations] { + if {[LoadAccelerator $e]} { + SwitchTo $e + break + } + } + unset e +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Export the constructor command. + namespace export set +} + +package provide struct::set 2.2.3 diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/struct/sets_c.tcl b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/struct/sets_c.tcl new file mode 100644 index 00000000..c9837e94 --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/struct/sets_c.tcl @@ -0,0 +1,93 @@ +#---------------------------------------------------------------------- +# +# sets_tcl.tcl -- +# +# Definitions for the processing of sets. C implementation. +# +# Copyright (c) 2007 by Andreas Kupries. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: sets_c.tcl,v 1.3 2008/03/25 07:15:34 andreas_kupries Exp $ +# +#---------------------------------------------------------------------- + +package require critcl +# @sak notprovided struct_setc +package provide struct_setc 2.1.1 +package require Tcl 8.5- + +namespace eval ::struct { + # Supporting code for the main command. + + catch { + #critcl::cheaders -g + #critcl::debug memory symbols + } + + critcl::cheaders sets/*.h + critcl::csources sets/*.c + + critcl::ccode { + /* -*- c -*- */ + + #include + } + + # Main command, set creation. + + critcl::ccommand set_critcl {dummy interp objc objv} { + /* Syntax - dispatcher to the sub commands. + */ + + static CONST char* methods [] = { + "add", "contains", "difference", "empty", + "equal","exclude", "include", "intersect", + "intersect3", "size", "subsetof", "subtract", + "symdiff", "union", + NULL + }; + enum methods { + S_add, S_contains, S_difference, S_empty, + S_equal,S_exclude, S_include, S_intersect, + S_intersect3, S_size, S_subsetof, S_subtract, + S_symdiff, S_union + }; + + int m; + + if (objc < 2) { + Tcl_WrongNumArgs (interp, objc, objv, "cmd ?arg ...?"); + return TCL_ERROR; + } else if (Tcl_GetIndexFromObj (interp, objv [1], methods, "option", + 0, &m) != TCL_OK) { + return TCL_ERROR; + } + + /* Dispatch to methods. They check the #args in detail before performing + * the requested functionality + */ + + switch (m) { + case S_add: return sm_ADD (NULL, interp, objc, objv); + case S_contains: return sm_CONTAINS (NULL, interp, objc, objv); + case S_difference: return sm_DIFFERENCE (NULL, interp, objc, objv); + case S_empty: return sm_EMPTY (NULL, interp, objc, objv); + case S_equal: return sm_EQUAL (NULL, interp, objc, objv); + case S_exclude: return sm_EXCLUDE (NULL, interp, objc, objv); + case S_include: return sm_INCLUDE (NULL, interp, objc, objv); + case S_intersect: return sm_INTERSECT (NULL, interp, objc, objv); + case S_intersect3: return sm_INTERSECT3 (NULL, interp, objc, objv); + case S_size: return sm_SIZE (NULL, interp, objc, objv); + case S_subsetof: return sm_SUBSETOF (NULL, interp, objc, objv); + case S_subtract: return sm_SUBTRACT (NULL, interp, objc, objv); + case S_symdiff: return sm_SYMDIFF (NULL, interp, objc, objv); + case S_union: return sm_UNION (NULL, interp, objc, objv); + } + /* Not coming to this place */ + } +} + +# ### ### ### ######### ######### ######### +## Ready diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/struct/sets_tcl.tcl b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/struct/sets_tcl.tcl new file mode 100644 index 00000000..ad76704f --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/struct/sets_tcl.tcl @@ -0,0 +1,452 @@ +#---------------------------------------------------------------------- +# +# sets_tcl.tcl -- +# +# Definitions for the processing of sets. +# +# Copyright (c) 2004-2008 by Andreas Kupries. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: sets_tcl.tcl,v 1.4 2008/03/09 04:38:47 andreas_kupries Exp $ +# +#---------------------------------------------------------------------- + +package require Tcl 8.5- + +namespace eval ::struct::set { + # Only export one command, the one used to instantiate a new tree + namespace export set_tcl +} + +########################## +# Public functions + +# ::struct::set::set -- +# +# Command that access all set commands. +# +# Arguments: +# cmd Name of the subcommand to dispatch to. +# args Arguments for the subcommand. +# +# Results: +# Whatever the result of the subcommand is. + +proc ::struct::set::set_tcl {cmd args} { + # Do minimal args checks here + if { [llength [info level 0]] == 1 } { + return -code error "wrong # args: should be \"$cmd ?arg arg ...?\"" + } + ::set sub S_$cmd + if { [llength [info commands ::struct::set::$sub]] == 0 } { + ::set optlist [info commands ::struct::set::S_*] + ::set xlist {} + foreach p $optlist { + lappend xlist [string range $p 17 end] + } + return -code error \ + "bad option \"$cmd\": must be [linsert [join [lsort $xlist] ", "] "end-1" "or"]" + } + return [uplevel 1 [linsert $args 0 ::struct::set::$sub]] +} + +########################## +# Implementations of the functionality. +# + +# ::struct::set::S_empty -- +# +# Determines emptiness of the set +# +# Parameters: +# set -- The set to check for emptiness. +# +# Results: +# A boolean value. True indicates that the set is empty. +# +# Side effects: +# None. +# +# Notes: + +proc ::struct::set::S_empty {set} { + return [expr {[llength $set] == 0}] +} + +# ::struct::set::S_size -- +# +# Computes the cardinality of the set. +# +# Parameters: +# set -- The set to inspect. +# +# Results: +# An integer greater than or equal to zero. +# +# Side effects: +# None. + +proc ::struct::set::S_size {set} { + return [llength [Cleanup $set]] +} + +# ::struct::set::S_contains -- +# +# Determines if the item is in the set. +# +# Parameters: +# set -- The set to inspect. +# item -- The element to look for. +# +# Results: +# A boolean value. True indicates that the element is present. +# +# Side effects: +# None. + +proc ::struct::set::S_contains {set item} { + return [expr {[lsearch -exact $set $item] >= 0}] +} + +# ::struct::set::S_union -- +# +# Computes the union of the arguments. +# +# Parameters: +# args -- List of sets to unify. +# +# Results: +# The union of the arguments. +# +# Side effects: +# None. + +proc ::struct::set::S_union {args} { + switch -exact -- [llength $args] { + 0 {return {}} + 1 {return [lindex $args 0]} + } + foreach setX $args { + foreach x $setX {::set ($x) {}} + } + return [array names {}] +} + + +# ::struct::set::S_intersect -- +# +# Computes the intersection of the arguments. +# +# Parameters: +# args -- List of sets to intersect. +# +# Results: +# The intersection of the arguments +# +# Side effects: +# None. + +proc ::struct::set::S_intersect {args} { + switch -exact -- [llength $args] { + 0 {return {}} + 1 {return [lindex $args 0]} + } + ::set res [lindex $args 0] + foreach set [lrange $args 1 end] { + if {[llength $res] && [llength $set]} { + ::set res [Intersect $res $set] + } else { + # Squash 'res'. Otherwise we get the wrong result if res + # is not empty, but 'set' is. + ::set res {} + break + } + } + return $res +} + +proc ::struct::set::Intersect {A B} { + if {[llength $A] == 0} {return {}} + if {[llength $B] == 0} {return {}} + + # This is slower than local vars, but more robust + if {[llength $B] > [llength $A]} { + ::set res $A + ::set A $B + ::set B $res + } + ::set res {} + foreach x $A {::set ($x) {}} + foreach x $B { + if {[info exists ($x)]} { + lappend res $x + } + } + return $res +} + +# ::struct::set::S_difference -- +# +# Compute difference of two sets. +# +# Parameters: +# A, B -- Sets to compute the difference for. +# +# Results: +# A - B +# +# Side effects: +# None. + +proc ::struct::set::S_difference {A B} { + if {[llength $A] == 0} {return {}} + if {[llength $B] == 0} {return $A} + + array set tmp {} + foreach x $A {::set tmp($x) .} + foreach x $B {catch {unset tmp($x)}} + return [array names tmp] +} + +if {0} { + # Tcllib SF Bug 1002143. We cannot use the implementation below. + # It will treat set elements containing '(' and ')' as array + # elements, and this screws up the storage of elements as the name + # of local vars something fierce. No way around this. Disabling + # this code and always using the other implementation (s.a.) is + # the only possible fix. + + if {[package vcompare [package provide Tcl] 8.4] < 0} { + # Tcl 8.[23]. Use explicit array to perform the operation. + } else { + # Tcl 8.4+, has 'unset -nocomplain' + + proc ::struct::set::S_difference {A B} { + if {[llength $A] == 0} {return {}} + if {[llength $B] == 0} {return $A} + + # Get the variable B out of the way, avoid collisions + # prepare for "pure list optimization" + ::set ::struct::set::tmp [lreplace $B -1 -1 unset -nocomplain] + unset B + + # unset A early: no local variables left + foreach [lindex [list $A [unset A]] 0] {.} {break} + + eval $::struct::set::tmp + return [info locals] + } + } +} + +# ::struct::set::S_symdiff -- +# +# Compute symmetric difference of two sets. +# +# Parameters: +# A, B -- The sets to compute the s.difference for. +# +# Results: +# The symmetric difference of the two input sets. +# +# Side effects: +# None. + +proc ::struct::set::S_symdiff {A B} { + # symdiff == (A-B) + (B-A) == (A+B)-(A*B) + if {[llength $A] == 0} {return $B} + if {[llength $B] == 0} {return $A} + return [S_union \ + [S_difference $A $B] \ + [S_difference $B $A]] +} + +# ::struct::set::S_intersect3 -- +# +# Return intersection and differences for two sets. +# +# Parameters: +# A, B -- The sets to inspect. +# +# Results: +# List containing A*B, A-B, and B-A +# +# Side effects: +# None. + +proc ::struct::set::S_intersect3 {A B} { + return [list \ + [S_intersect $A $B] \ + [S_difference $A $B] \ + [S_difference $B $A]] +} + +# ::struct::set::S_equal -- +# +# Compares two sets for equality. +# +# Parameters: +# a First set to compare. +# b Second set to compare. +# +# Results: +# A boolean. True if the lists are equal. +# +# Side effects: +# None. + +proc ::struct::set::S_equal {A B} { + ::set A [Cleanup $A] + ::set B [Cleanup $B] + + # Equal if of same cardinality and difference is empty. + + if {[::llength $A] != [::llength $B]} {return 0} + return [expr {[llength [S_difference $A $B]] == 0}] +} + + +proc ::struct::set::Cleanup {A} { + # unset A to avoid collisions + if {[llength $A] < 2} {return $A} + # We cannot use variables to avoid an explicit array. The set + # elements may look like namespace vars (i.e. contain ::), and + # such elements break that, cannot be proc-local variables. + array set S {} + foreach item $A {set S($item) .} + return [array names S] +} + +# ::struct::set::S_include -- +# +# Add an element to a set. +# +# Parameters: +# Avar -- Reference to the set variable to extend. +# element -- The item to add to the set. +# +# Results: +# None. +# +# Side effects: +# The set in the variable referenced by Avar is extended +# by the element (if the element was not already present). + +proc ::struct::set::S_include {Avar element} { + # Avar = Avar + {element} + upvar 1 $Avar A + if {![info exists A] || ![S_contains $A $element]} { + lappend A $element + } + return +} + +# ::struct::set::S_exclude -- +# +# Remove an element from a set. +# +# Parameters: +# Avar -- Reference to the set variable to shrink. +# element -- The item to remove from the set. +# +# Results: +# None. +# +# Side effects: +# The set in the variable referenced by Avar is shrunk, +# the element remove (if the element was actually present). + +proc ::struct::set::S_exclude {Avar element} { + # Avar = Avar - {element} + upvar 1 $Avar A + if {![info exists A]} {return -code error "can't read \"$Avar\": no such variable"} + while {[::set pos [lsearch -exact $A $element]] >= 0} { + ::set A [lreplace [K $A [::set A {}]] $pos $pos] + } + return +} + +# ::struct::set::S_add -- +# +# Add a set to a set. Similar to 'union', but the first argument +# is a variable. +# +# Parameters: +# Avar -- Reference to the set variable to extend. +# B -- The set to add to the set in Avar. +# +# Results: +# None. +# +# Side effects: +# The set in the variable referenced by Avar is extended +# by all the elements in B. + +proc ::struct::set::S_add {Avar B} { + # Avar = Avar + B + upvar 1 $Avar A + if {![info exists A]} {set A {}} + ::set A [S_union [K $A [::set A {}]] $B] + return +} + +# ::struct::set::S_subtract -- +# +# Remove a set from a set. Similar to 'difference', but the first argument +# is a variable. +# +# Parameters: +# Avar -- Reference to the set variable to shrink. +# B -- The set to remove from the set in Avar. +# +# Results: +# None. +# +# Side effects: +# The set in the variable referenced by Avar is shrunk, +# all elements of B are removed. + +proc ::struct::set::S_subtract {Avar B} { + # Avar = Avar - B + upvar 1 $Avar A + if {![info exists A]} {return -code error "can't read \"$Avar\": no such variable"} + ::set A [S_difference [K $A [::set A {}]] $B] + return +} + +# ::struct::set::S_subsetof -- +# +# A predicate checking if the first set is a subset +# or equal to the second set. +# +# Parameters: +# A -- The possible subset. +# B -- The set to compare to. +# +# Results: +# A boolean value, true if A is subset of or equal to B +# +# Side effects: +# None. + +proc ::struct::set::S_subsetof {A B} { + # A subset|== B <=> (A == A*B) + return [S_equal $A [S_intersect $A $B]] +} + +# ::struct::set::K -- +# Performance helper command. + +proc ::struct::set::K {x y} {::set x} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Put 'set::set' into the general structure namespace + # for pickup by the main management. + + namespace import -force set::set_tcl +} diff --git a/src/modules/punk/mix/templates/layouts/project/src/doc/include/changes_0.1.inc b/src/modules/punk/mix/templates/layouts/project/src/doc/include/changes_0.1.inc index 08788e2b..258ec5bd 100644 --- a/src/modules/punk/mix/templates/layouts/project/src/doc/include/changes_0.1.inc +++ b/src/modules/punk/mix/templates/layouts/project/src/doc/include/changes_0.1.inc @@ -1,25 +1,28 @@ [subsection {Changes for version 0.1}] -[vset punkshell_project https://www.gitea1.intx.com.au/jn/punkshell] This release 0.1 of project %project% -[para] In detail: - +[para] Summary [list_begin enumerated] -[comment {- - -- --- ----- -------- ------------- ---------------------}] -[enum] %project% requires Tcl 8.6 or higher. Tcl 8.5 or less is not - supported. -[comment {- - -- --- ----- -------- ------------- ---------------------}] -[comment {Please consider retaining a link to PunkShell to support the project}] -[enum] This project uses [uri [vset punkshell_project] {PunkShell}] as a deployment management and documentation tool. -[comment {- - -- --- ----- -------- ------------- ---------------------}] + [enum] feature 1 + [enum] feature 2 +[list_end] -[para] Summary +[para] In detail: [list_begin enumerated] -[enum] feature 1 -[enum] feature 2 + [comment {- - -- --- ----- -------- ------------- ---------------------}] + + [enum] %project% requires Tcl 8.6 or higher. Tcl 8.5 or less is not + supported. + + [comment {- - -- --- ----- -------- ------------- ---------------------}] + + [enum] + + [comment {- - -- --- ----- -------- ------------- ---------------------}] [list_end] + + [comment {- - -- --- ----- -------- ------------- ---------------------}] -[list_end] diff --git a/src/modules/punk/mix/templates/layouts/project/src/make.tcl b/src/modules/punk/mix/templates/layouts/project/src/make.tcl index 30dc928c..3eec3941 100644 --- a/src/modules/punk/mix/templates/layouts/project/src/make.tcl +++ b/src/modules/punk/mix/templates/layouts/project/src/make.tcl @@ -2,8 +2,6 @@ # #make any tclkits and modules in src and place them and associated data files/scripts in the parent folder of src. #e.g in 'bin' and 'modules' folders at same level as 'src' folder. -#It is assumed the src folder has been placed somewhere where appropriate -#(e.g not in /usr or c:/ - unless you intend it to directly make and place folders and files in those locations) set hashline "# ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###" puts $hashline @@ -25,13 +23,18 @@ if {"::try" ni [info commands ::try]} { #------------------------------------------------------------------------------ #Module loading from /src/bootsupport or src/*.vfs if script is within a .vfs folder #------------------------------------------------------------------------------ -#If the there is a folder directly under the current directory /src/bootsupport/modules which contains .tm files when the starts +#If the there is a folder under the current directory /src/bootsupport/modules which contains .tm files # - then it will attempt to preference these modules -# This allows a source update via 'fossil update' 'git pull' etc to pull in support modules for the make script -# and load these in preference to ones that may have been in the interps tcl::tm::list or auto_path due to environment variables +# This allows a source update via 'fossil update' 'git pull' etc to pull in a minimal set of support modules for the make script +# and load these in preference to ones that may have been in the interp's tcl::tm::list or auto_path due to environment variables set startdir [pwd] -set bootsupport_mod [file join $startdir src bootsupport modules] -set bootsupport_lib [file join $startdir src bootsupport lib] +if {[file exists [file join $startdir src bootsupport]]} { + set bootsupport_mod [file join $startdir src bootsupport modules] + set bootsupport_lib [file join $startdir src bootsupport lib] +} else { + set bootsupport_mod [file join $startdir bootsupport modules] + set bootsupport_lib [file join $startdir bootsupport lib] +} if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} { set original_tm_list [tcl::tm::list] @@ -60,31 +63,16 @@ if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} { } - #todo - review usecase - if {[string match "*.vfs/*" [info script]]} { - #src/xxx.vfs/lib/app-punk/repl.tcl - #we assume if calling directly into .vfs that the user would prefer to use src/modules - so go up 4 levels - set modulefolder [file dirname [file dirname [file dirname [file dirname [info script]]]]]/modules - - } else { - # .../bin/punkXX.exe look for ../modules (i.e modules folder at same level as bin folder) - set modulefolder [file dirname [file dirname [info nameofexecutable]]]/modules - } - - if {[file exists $modulefolder]} { - tcl::tm::add $modulefolder - } else { - puts stderr "Warning unable to find module folder at: $modulefolder" - } if {[file exists [pwd]/modules]} { tcl::tm::add [pwd]/modules } #package require Thread - #These are strong dependencies - # - the repl requires Threading and punk,shellfilter,shellrun to call and display properly. + # - the full repl requires Threading and punk,shellfilter,shellrun to call and display properly. + + # tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list - + #These are strong dependencies package forget punk::mix package require punk::mix package forget punk::repo @@ -144,6 +132,8 @@ proc punkmake_gethelp {args} { append h " $scriptname project ?-k?" \n append h " - this is the literal word project - and confirms you want to run the project build" \n append h " - the optional -k flag will terminate processes running as the executable being built (if applicable)" \n \n + append h " $scriptname bootsupport" \n + append h " - update the src/bootsupport modules as well as the mixtemplates/layouts//src/bootsupport modules if the folder exists" \n \n append h " $scriptname get-project-info" \n append h " - show the name and base folder of the project to be built" \n append h "" \n @@ -189,7 +179,7 @@ if {[llength $commands_found] != 1 } { } if {$do_help} { puts stderr [punkmake_gethelp] - exit 1 + exit 0 } set ::punkmake::command [lindex $commands_found 0] @@ -224,6 +214,8 @@ if {![string length [set projectroot [punk::repo::find_project $scriptfolder]]]} } +set sourcefolder $projectroot/src + if {$::punkmake::command eq "get-project-info"} { puts stdout "- -- --- --- --- --- --- --- --- --- ---" puts stdout "- -- get-project-info -- -" @@ -260,9 +252,128 @@ if {$::punkmake::command eq "shell"} { } if {$::punkmake::command eq "bootsupport"} { + puts "projectroot: $projectroot" + puts "script: [info script]" + #puts "-- [tcl::tm::list] --" + puts stdout "Updating bootsupport from local files" + + proc bootsupport_localupdate {projectroot} { + set bootsupport_modules [list] + set bootsupport_config $projectroot/src/bootsupport/include_modules.config ;# + if {[file exists $bootsupport_config]} { + source $bootsupport_config ;#populate $bootsupport_modules with project-specific list + if {![llength $bootsupport_modules]} { + puts stderr "No local bootsupport modules configured for updating" + return + } + set targetroot $projectroot/src/bootsupport/modules + if {[catch { + #---------- + set boot_installer [punkcheck::installtrack new make.tcl $projectroot/src/bootsupport/.punkcheck] + $boot_installer set_source_target $projectroot $projectroot/src/bootsupport + set boot_event [$boot_installer start_event {-make_step bootsupport}] + #---------- + } errM]} { + puts stderr "Unable to use punkcheck for bootsupport error: $errM" + set boot_event "" + } - exit 1 + foreach {relpath module} $bootsupport_modules { + set module [string trim $module :] + set module_subpath [string map [list :: /] [namespace qualifiers $module]] + set srclocation [file join $projectroot $relpath $module_subpath] + #puts stdout "$relpath $module $module_subpath $srclocation" + set pkgmatches [glob -nocomplain -dir $srclocation -tail [namespace tail $module]-*] + #lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1 + if {![llength $pkgmatches]} { + puts stderr "Missing source for bootsupport module $module - not found in $srclocation" + continue + } + set latestfile [lindex $pkgmatches 0] + set latestver [lindex [split [file rootname $latestfile] -] 1] + foreach m $pkgmatches { + lassign [split [file rootname $m] -] _pkg ver + #puts "comparing $ver vs $latestver" + if {[package vcompare $ver $latestver] == 1} { + set latestver $ver + set latestfile $m + } + } + set srcfile [file join $srclocation $latestfile] + set tgtfile [file join $targetroot $module_subpath $latestfile] + if {$boot_event ne ""} { + #---------- + $boot_event targetset_init INSTALL $tgtfile + $boot_event targetset_addsource $srcfile + #---------- + if {\ + [llength [dict get [$boot_event targetset_source_changes] changed]]\ + || [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\ + } { + $boot_event targetset_started + # -- --- --- --- --- --- + puts "BOOTSUPPORT update: $srcfile -> $tgtfile" + if {[catch { + file copy -force $srcfile $tgtfile + } errM]} { + $boot_event targetset_end FAILED + } else { + $boot_event targetset_end OK + } + # -- --- --- --- --- --- + } else { + puts -nonewline stderr "." + $boot_event targetset_end SKIPPED + } + $boot_event end + } else { + file copy -force $srcfile $tgtfile + } + } + if {$boot_event ne ""} { + puts \n + $boot_event destroy + $boot_installer destroy + } + } + } + + bootsupport_localupdate $projectroot + + #/modules/punk/mix/templates/layouts only applies if the project has it's own copy of the punk/mix modules. Generally this should only apply to the punkshell project itself. + set layout_bases [list\ + $sourcefolder/mixtemplates/layouts\ + $sourcefolder/modules/punk/mix/templates/layouts\ + ] + foreach project_layout_base $layout_bases { + if {[file exists $project_layout_base]} { + set project_layouts [glob -nocomplain -dir $project_layout_base -type d -tail *] + foreach layoutname $project_layouts { + if {[file exists [file join $project_layout_base $layoutname/src/bootsupport]]} { + set unpublish [list\ + README.md\ + ] + set sourcemodules $projectroot/src/bootsupport/modules + set targetroot [file join $project_layout_base $layoutname/src/bootsupport/modules] + file mkdir $targetroot + + puts stdout "BOOTSUPPORT layouts/$layoutname: copying from $sourcemodules to $targetroot (if source file changed)" + set resultdict [punkcheck::install $sourcemodules $targetroot -overwrite installedsourcechanged-targets -unpublish_paths $unpublish] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + flush stdout + } + } + } else { + puts stderr "No layout base at $project_layout_base" + } + } + puts stdout " bootsupport done " + flush stderr + flush stdout + #punk86 can hang if calling make.tcl via 'run' without this 'after' delay. punk87 unaffected. cause unknown. + #after 500 + ::exit 0 } @@ -273,7 +384,6 @@ if {$::punkmake::command ne "project"} { } -set sourcefolder $projectroot/src #only a single consolidated /modules folder used for target set target_modules_base $projectroot/modules @@ -749,8 +859,14 @@ foreach vfs $vfs_folders { } errMsg]} { puts stderr "$killcmd returned an error:" puts stderr $errMsg - puts stderr "(try '[info script] -k' option to force kill)" - exit 4 + if {!$forcekill} { + puts stderr "(try '[info script] -k' option to force kill)" + } + #avoid exiting if the kill failure was because the task has already exited + #review - *no running instance* works with windows taskkill - "*No such process*" works with kill -9 on FreeBSD and linux - other platforms? + if {![string match "*no running instance*" $errMsg] && ![string match "*No such process*" $errMsg]} { + exit 4 + } } else { puts stderr "$killcmd ran without error" incr count_killed @@ -790,6 +906,9 @@ foreach vfs $vfs_folders { $bin_installer set_source_target $buildfolder $deployment_folder set bin_event [$bin_installer start_event {-make-step final_kit_install}] $bin_event targetset_init INSTALL $deployment_folder/$targetkit + #todo - move final deployment step outside of the build vfs loop? (final deployment can fail and then isn't rerun even though _build and deployed versions differ, unless .vfs modified again) + #set last_completion [$bin_event targetset_last_complete] + $bin_event targetset_addsource $buildfolder/$targetkit $bin_event targetset_started # -- ---------- @@ -802,7 +921,6 @@ foreach vfs $vfs_folders { file delete $deployment_folder/$targetkit } errMsg]} { puts stderr "deletion of deployed version at $deployment_folder/$targetkit failed: $errMsg" - #exit 5 set delete_failed 1 } } @@ -818,6 +936,7 @@ foreach vfs $vfs_folders { # -- ---------- } else { $bin_event targetset_end FAILED -note "could not delete" + exit 5 } $bin_event destroy $bin_installer destroy diff --git a/src/modules/punk/mix/templates/layouts/project/src/mixtemplates/layouts/basic/src/bootsupport/modules/README.md b/src/modules/punk/mix/templates/layouts/project/src/mixtemplates/layouts/basic/src/bootsupport/modules/README.md new file mode 100644 index 00000000..7646295d --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/mixtemplates/layouts/basic/src/bootsupport/modules/README.md @@ -0,0 +1,24 @@ +This is primarily for tcl .tm modules required for your bootstrapping/make/build process. +It could include other files necessary for this process. + +The .tm modules here may be required for your build script if it intended the installation operator uses an existing tclsh or other shell as opposed to a tclkit you may have for distribution which is more likely to include necessary libraries. + +The modules here are loaded by your initialisation scripts and so can be a snapshot of different versions than those in your project src. +The modules can be your own, or 3rd party such as individual items from tcllib. + +You can copy modules from a running punk shell to this location using the pmix command. + +e.g +>pmix visible_lib_copy_to_modulefolder some::module::lib bootsupport + +The pmix command will help you pick the latest version, and will create any necessary file structure matching the namespace of the package. + +e.g the result might be a file such as +/src/bootsupport/some/module/lib-0.1.tm + +The originating library may not yet be in .tm form. +You can copy a pkgIndex.tcl based library that is composed of a single .tcl file the same way using the above process and it will automatically name and file it appropriately but you need to check that the library doesn't require/load additional files - and that it is Tcl script only. + +Always verify that the library is copyable in this manner and test in a shell with tcl::tm::path pointed to ./bootsupport that it works. + + diff --git a/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/modules/shellthread-1.6.tm b/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/modules/shellthread-1.6.tm index 574dbda5..7085e66d 100644 --- a/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/modules/shellthread-1.6.tm +++ b/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/modules/shellthread-1.6.tm @@ -604,6 +604,10 @@ namespace eval shellthread::manager { return $taginfo_list } + #TODO - important. + #REVIEW! + #since moving to the unsubscribe mechansm - close_worker $source isn't being called + # - we need to set a limit to the number of free threads and shut down excess when detected during unsubscription #instruction to shut-down the thread that has this source. proc close_worker {source {timeout 2500}} { variable workers diff --git a/src/modules/punk/overlay-0.1.tm b/src/modules/punk/overlay-0.1.tm index d16f57f5..f5653c35 100644 --- a/src/modules/punk/overlay-0.1.tm +++ b/src/modules/punk/overlay-0.1.tm @@ -89,7 +89,11 @@ namespace eval ::punk::overlay { #This won't stop the commandset being used with other cli/bases unless the import is done by looking up the callers namespace. #The basic principle is that the commandset is loaded into the caller(s) with a prefix #- but commandsets should explicitly package require if they have any backwards dependencies on cli/base (which they may or may not be loaded into) - proc import_commandset {prefix cmdnamespace} { + proc import_commandset {prefix separator cmdnamespace} { + set bad_seps [list "::"] + if {$separator in $bad_seps} { + error "import_commandset invalid separator '$separator'" + } #namespace may or may not be a package # allow with or without leading :: if {[string range $cmdnamespace 0 1] eq "::"} { @@ -110,7 +114,7 @@ namespace eval ::punk::overlay { } else { set provinfo "(package $cmdpackage not present)" } - error "punk::mix::base::lib::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Usage: import_commandset prefix namespace" + error "punk::overlay::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Usage: import_commandset prefix separator namespace" } } @@ -130,12 +134,17 @@ namespace eval ::punk::overlay { if {[catch { namespace eval ${nscaller}::temp_import [list namespace import ${cmdnamespace}::*] foreach cmd [info commands ${nscaller}::temp_import::*] { - set import_as ${nscaller}::$prefix[namespace tail $cmd] + set cmdtail [namespace tail $cmd] + if {$cmdtail eq "_default"} { + set import_as ${nscaller}::${prefix} + } else { + set import_as ${nscaller}::${prefix}${separator}${cmdtail} + } rename $cmd $import_as lappend imported_commands $import_as } } errM]} { - puts stderr "Error loading commandset $prefix $cmdnamespace" + puts stderr "Error loading commandset $prefix $separator $cmdnamespace" puts stderr "err: $errM" } return $imported_commands diff --git a/src/modules/punk/repl-0.1.tm b/src/modules/punk/repl-0.1.tm index 5aeb28eb..3a68ba99 100644 --- a/src/modules/punk/repl-0.1.tm +++ b/src/modules/punk/repl-0.1.tm @@ -133,7 +133,8 @@ package require term::ansi::code::ctrl if {$::tcl_platform(platform) eq "windows"} { package require zzzload zzzload::pkg_require twapi - after idle [list after 2000 { + after idle [list after 1000 { + #puts stdout "===============repl loading twapi===========" zzzload::pkg_wait twapi if {![catch {package require twapi}]} { diff --git a/src/modules/punkcheck-0.1.0.tm b/src/modules/punkcheck-0.1.0.tm index a65e1f7a..41d8759a 100644 --- a/src/modules/punkcheck-0.1.0.tm +++ b/src/modules/punkcheck-0.1.0.tm @@ -234,10 +234,12 @@ namespace eval punkcheck { #related - installfile_begin #call init before we know if we are going to run the operation vs skip method targetset_init {operation targetset} { - set known_ops [list INSTALL MODIFY DELETE VIRTUAL] + set known_ops [list QUERY INSTALL MODIFY DELETE VIRTUAL] if {[string toupper $operation] ni $known_ops} { error "[self] add_target unknown operation '$operation'. Known operations $known_ops" } + set o_operation [string toupper $operation] + if {$o_operation_start_ts ne ""} { error "[self] targetset_tart $o_operation operation already in progress. Use targetset_finished or targetset_complete to finish." } @@ -245,18 +247,24 @@ namespace eval punkcheck { set seconds [expr {$o_operation_start_ts / 1000000}] set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] set relativepath_targetset [list] - foreach p $targetset { - if {[file pathtype $p] eq "absolute"} { - lappend relativepath_targetset [punkcheck::lib::path_relative [file dirname $punkcheck_file] $p] - } else { + if {$o_operation eq "VIRTUAL"} { + foreach p $targetset { lappend relativepath_targetset $p } + } else { + foreach p $targetset { + if {[file pathtype $p] eq "absolute"} { + lappend relativepath_targetset [punkcheck::lib::path_relative $punkcheck_folder $p] + } else { + lappend relativepath_targetset $p + } + } } - set o_operation $operation set fields [list\ -tsiso $tsiso\ -ts $o_operation_start_ts\ @@ -280,7 +288,7 @@ namespace eval punkcheck { #-installer and -eventid keys are added here set new_inprogress_record [dict create tag [string toupper $operation]-INPROGRESS {*}$fields -tempcontext [my as_record] body {}] #set existing_body [dict_getwithdefault $o_fileset_record body [list]] - #todo - look for existing "-INPROGRESS" records - mark as failed? + #todo - look for existing "-INPROGRESS" records - mark as failed or incomplete? dict lappend o_fileset_record body $new_inprogress_record if {$isnew} { @@ -288,15 +296,36 @@ namespace eval punkcheck { } else { set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record] } - - punkcheck::save_records_to_file $record_list $punkcheck_file + if {$o_operation ne "QUERY"} { + punkcheck::save_records_to_file $record_list $punkcheck_file + } return $o_fileset_record } #operation has been started + #todo - upgrade .punkcheck format to hold more than just list of SOURCE entries in each record. + # - allow arbitrary targetset_startphase targetset_endphase calls to store timestamps and calculate elapsed time method targetset_started {} { set punkcheck_folder [file dirname [$o_installer get_checkfile]] - set o_fileset_record [punkcheck::installfile_started_install $punkcheck_folder $o_fileset_record] + if {$o_operation eq "QUERY"} { + set fileinfo_body [dict get $o_fileset_record body] ;#body of FILEINFO record + set installing_record [lindex $fileinfo_body end] + + set ts_start [dict get $installing_record -ts] + set ts_now [clock microseconds] + set metadata_us [expr {$ts_now - $ts_start}] + + dict set installing_record -metadata_us $metadata_us + dict set installing_record -ts_start_transfer $ts_now + + lset fileinfo_body end $installing_record + + return [dict set o_fileset_record body $fileinfo_body] + } else { + #legacy call + #saves to .punkcheck file + return [set o_fileset_record [punkcheck::installfile_started_install $punkcheck_folder $o_fileset_record]] + } } method targetset_end {status args} { set defaults [dict create\ @@ -311,7 +340,6 @@ namespace eval punkcheck { dict unset opts -note } - set status [string toupper $status] set statusdict [dict create OK RECORD SKIPPED SKIPPED FAILED FAILED] if {$o_operation_start_ts eq ""} { @@ -332,6 +360,7 @@ namespace eval punkcheck { set file_record_body [dict get $o_fileset_record body] set installing_record [lindex $file_record_body end] set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] set record_list [punkcheck::load_records_from_file $punkcheck_file] if {[dict exists $installing_record -ts_start_transfer]} { set ts_start_transfer [dict get $installing_record -ts_start_transfer] @@ -345,6 +374,23 @@ namespace eval punkcheck { dict set installing_record -elapsed_us $elapsed_us dict unset installing_record -tempcontext dict set installing_record tag "${o_operation}-[dict get $statusdict $status]" ;# e.g INSTALL-RECORD, INSTALL-SKIPPED + if {$o_operation in [list INSTALL MODIFY] && [dict get $statusdict $status] eq "RECORD"} { + #only calculate and store post operation target cksums on successful INSTALL or MODIFY, doesn't make sense for DELETE or VIRTUAL operations + set new_targets_cksums [list] ;#ordered list of cksums matching targetset order + set cksum_all_opts "" ;#same cksum opts for each target so we store it once + set ts_begin_cksum [clock microseconds] + foreach p $o_targets { + set tgt_cksum_info [punk::mix::base::lib::cksum_path [file join $punkcheck_folder $p]] + lappend new_targets_cksums [dict get $tgt_cksum_info cksum] + if {$cksum_all_opts eq ""} { + set cksum_all_opts [dict get $tgt_cksum_info opts] + } + } + set cksum_us [expr {[clock microseconds] - $ts_begin_cksum}] + dict set installing_record -targets_cksums $new_targets_cksums + dict set installing_record -cksum_all_opts $cksum_all_opts + dict set installing_record -cksum_us $cksum_us + } lset file_record_body end $installing_record dict set o_fileset_record body $file_record_body set o_fileset_record [punkcheck::recordlist::file_record_prune $o_fileset_record] @@ -356,7 +402,9 @@ namespace eval punkcheck { } else { lset record_list $old_posn $o_fileset_record } - punkcheck::save_records_to_file $record_list $punkcheck_file + if {$o_operation ne "QUERY"} { + punkcheck::save_records_to_file $record_list $punkcheck_file + } set o_operation_start_ts "" set o_operation "" return $o_fileset_record @@ -372,6 +420,20 @@ namespace eval punkcheck { set o_fileset_record [punkcheck::installfile_add_source_and_fetch_metadata $punkcheck_folder $rel_source_path $o_fileset_record] + } + method targetset_last_complete {} { + #retrieve last completed record for the fileset ie exclude SKIPPED,INSTALL-INPROGRESS,DELETE-INPROGRESS,MODIFY-INPROGRESS + set body [punkcheck::dict_getwithdefault $o_fileset_record body [list]] + set previous_records [lrange $body 0 end] + #get last that is tagged INSTALL-RECORD,MODIFY-RECORD,DELETE-RECORD + set revlist [lreverse $previous_records] + foreach rec $revlist { + if {[dict get $rec tag] in [list "INSTALL-RECORD" "MODIFY-RECORD" "DELETE-RECORD" "VIRTUAL-RECORD"]} { + return $rec + } + } + return [list] + } method targetset_source_changes {} { punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $o_fileset_record body] end] @@ -551,16 +613,6 @@ namespace eval punkcheck { method get_event {} { return $o_active_event } - if 0 { - method unknown {args} { - puts "[self] unknown called with args:$args" - if {[llength $args]} { - - } else { - - } - } - } } } proc start_installer_event {punkcheck_file installername from_fullpath to_fullpath config} { @@ -722,6 +774,10 @@ namespace eval punkcheck { } else { set cksum_opts "" } + + #todo - accept argument of cached source cksum info (for client calling multiple targets with same source in quick succession e.g when building .vfs kits with multiple runtimes) + #if same cksum_opts - then use cached data instead of checksumming here. + #allow nonexistant as a source set fpath [file join $punkcheck_folder $source_relpath] if {![file exists $fpath]} { @@ -857,7 +913,7 @@ namespace eval punkcheck { set tsnow [clock microseconds] set elapsed_us [expr {$tsnow - $ts_start}] dict set installing_record -elapsed_us $elapsed_us - dict set installing_record tag "SKIPPED" + dict set installing_record tag "INSTALL-SKIPPED" lset file_record_body end $installing_record dict set file_record body $file_record_body @@ -879,13 +935,14 @@ namespace eval punkcheck { #then: file_record_add_installrecord namespace eval lib { + set pkg punkcheck namespace path ::punkcheck proc is_file_record_inprogress {file_record} { if {[dict get $file_record tag] ne "FILEINFO"} { return 0 } set installing_record [lindex [dict_getwithdefault $file_record body [list]] end] - if {[dict_getwithdefault $installing_record tag [list]] ni [list INSTALL-INPROGRESS MODIFY-INPROGRESS DELETE-INPROGRESS VIRTUAL-INPROGRESS]} { + if {[dict_getwithdefault $installing_record tag [list]] ni [list QUERY-INPROGRESS INSTALL-INPROGRESS MODIFY-INPROGRESS DELETE-INPROGRESS VIRTUAL-INPROGRESS]} { return 0 } return 1 @@ -1021,9 +1078,16 @@ namespace eval punkcheck { } proc install_non_tm_files {srcdir basedir args} { #set keys [dict keys $args] + #adjust the default anti_glob_dir_core entries so that .fossil-custom, .fossil-settings are copied + set antiglob_dir_core [punkcheck::default_antiglob_dir_core] + set posn [lsearch $antiglob_dir_core ".fossil*"] + if {$posn >=0} { + set antiglob_dir_core [lreplace $antiglob_dir_core $posn $posn] + } set defaults [list\ -glob *\ -antiglob_file [list "*.tm" "*-buildversion.txt" "*.exe"]\ + -antiglob_dir_core $antiglob_dir_core\ -installer punkcheck::install_non_tm_files\ ] set opts [dict merge $defaults $args] @@ -1070,7 +1134,8 @@ namespace eval punkcheck { # -overwrite newer-targets will copy files with older source timestamp over newer target timestamp and those missing at the target (a form of 'restore' operation) # -overwrite older-targets will copy files with newer source timestamp over older target timestamp and those missing at the target # -overwrite all-targets will copy regardless of timestamp at target - # -overwrite installedsourcechanged-targets + # -overwrite installedsourcechanged-targets will copy if the target doesn't exist or the source changed + # -overwrite synced-targets will copy if the target doesn't exist or the source changed and the target cksum is the same as the last INSTALL-RECORD targets_cksums entry # review - timestamps unreliable # - what about slightly mismatched system clocks and mounted filesystems? caller responsibility to verify first? # if timestamp exactly equal - should we check content-hash? This is presumably only likely to occur deliberately(maliciously?) @@ -1091,11 +1156,13 @@ namespace eval punkcheck { # -source_checksum compare|store|comparestore|false|true where true == comparestore # -punkcheck_folder target|source|project| target is default and is generally recommended # -punkcheck_records empty string | parsed TDL records ie {tag xxx k v} structure + # install creates FILEINFO records with a single entry in the -targets field (it is legitimate to have a list of targets for an installation operation - the oo interface supports this) proc install {srcdir tgtdir args} { set defaults [list\ -call-depth-internal 0\ -max_depth 1000\ -subdirlist {}\ + -createdir 0\ -glob *\ -antiglob_file_core "\uFFFF"\ -antiglob_file "" \ @@ -1130,11 +1197,15 @@ namespace eval punkcheck { set max_depth [dict get $opts -max_depth] set subdirlist [dict get $opts -subdirlist] ;# generally should be same length as CALLDEPTH - but user could prefill set fileglob [dict get $opts -glob] + set createdir [dict get $opts -createdir] ;#defaults to zero to help avoid mistakes with initial target dir - required target subdirs are created regardless of this setting if {$CALLDEPTH == 0} { #expensive to normalize but we need to do it at least once set srcdir [file normalize $srcdir] set tgtdir [file normalize $tgtdir] + if {$createdir} { + file mkdir $tgtdir + } #now the values we build from these will be properly cased } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -1157,7 +1228,7 @@ namespace eval punkcheck { set opt_unpublish_paths [dict get $opts -unpublish_paths] ;#todo - combine with config file in source tree .punkcheckpublish (?) set unpublish_paths_matched [list] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - set known_whats [list no-targets newer-targets older-targets all-targets installedsourcechanged-targets] + set known_whats [list no-targets newer-targets older-targets all-targets installedsourcechanged-targets synced-targets] set overwrite_what [string tolower [dict get $opts -overwrite]]; #accept any case for value to allow emphasis by caller e.g -overwrite NEWER-TARGETS if {$overwrite_what ni $known_whats} { error "punkcheck::install received unrecognised value for -overwrite. Received value '$overwrite_what' vs known values '$known_whats'" @@ -1246,9 +1317,9 @@ namespace eval punkcheck { } if {[string match *store* $opt_source_checksum]} { - set store_cksums 1 + set store_source_cksums 1 } else { - set store_cksums 0 + set store_source_cksums 0 } @@ -1280,7 +1351,7 @@ namespace eval punkcheck { #puts "testing folder - globmatchpath $unpub $relative_source_dir" if {[globmatchpath $unpub $relative_source_dir]} { lappend unpublish_paths_matched $current_source_dir - return [list files_copied {} files_skipped {} sources_unchanged {} punkcheck_records $punkcheck_records unpublish_paths_matched $unpublish_paths_matched] + return [list files_copied {} files_skipped {} sources_unchanged {} punkcheck_records $punkcheck_records unpublish_paths_matched $unpublish_paths_matched srcdir $srcdir tgtdir $tgtdir punkcheck_folder $punkcheck_folder] } } @@ -1343,6 +1414,7 @@ namespace eval punkcheck { #puts stdout "Current target dir: $current_target_dir" foreach m $match_list { + set new_tgt_cksum_info [list] set relative_target_path [file join $relative_target_dir $m] set relative_source_path [file join $relative_source_dir $m] set punkcheck_target_relpath [file join $target_relative_to_punkcheck_dir $m] @@ -1400,10 +1472,14 @@ namespace eval punkcheck { #this hits the filesystem for the sourcepath - gets checksums/timestamps depending on config. #It doesn't save to .punkcheck (the only punkcheck::installfile_ method which doesn't) set filerec [punkcheck::installfile_add_source_and_fetch_metadata $punkcheck_folder $relative_source_path $filerec] - + + + + #changeinfo comes from last record in body - which is the record we are working on and so will always exist set changeinfo [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $filerec body] end]] set changed [dict get $changeinfo changed] set unchanged [dict get $changeinfo unchanged] + if {[llength $unchanged]} { lappend sources_unchanged $current_source_dir/$m } @@ -1415,6 +1491,7 @@ namespace eval punkcheck { } else { if {![file exists $current_target_dir/$m]} { file copy $current_source_dir/$m $current_target_dir + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] lappend files_copied $current_source_dir/$m incr filecount_new } else { @@ -1422,15 +1499,48 @@ namespace eval punkcheck { if {[llength $changed]} { #An unrecorded installation is considered a source change (from unknown/unrecorded source to recorded) file copy -force $current_source_dir/$m $current_target_dir + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] lappend files_copied $current_source_dir/$m } else { set is_skip 1 lappend files_skipped $current_source_dir/$m } + } elseif {$overwrite_what eq "synced-targets"} { + if {[llength $changed]} { + #only overwrite if the target checksum equals the last installed checksum (ie target is in sync with source and so hasn't been customized) + set existing_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + set is_target_unmodified_since_install 0 + set target_cksum_compare "unknown" + set latest_install_record [punkcheck::recordlist::file_record_latest_installrecord $filerec] ;#may be no such record - in which case we get an empty list + if {[dict exists $latest_install_record -targets_cksums]} { + set last_install_cksum [dict get $latest_install_record -targets_cksums] ;#in this case we know there is only one as 'install' always uses targetset size of 1. (FILEINFO record per file in source folder) + if {[dict get $existing_tgt_cksum_info cksum] eq $last_install_cksum} { + set is_target_unmodified_since_install 1 + set target_cksum_compare "match" + } else { + set target_cksum_compare "nomatch" + } + } else { + set target_cksum_compare "norecord" + } + if {$is_target_unmodified_since_install} { + file copy -force $current_source_dir/$m $current_target_dir + set new_tgt_cksum_info [punk::mix::base::lib::cksum_path $current_target_dir/$m] + lappend files_copied $current_source_dir/$m + } else { + #either cksum is different or we were unable to verify the record. Either way we can't know if the target is in sync so we must skip it + set is_skip 1 + puts stderr "Skipping file copy $m target $current_target_dir/$m - require synced_target to overwrite - current target cksum compared to previous install: $target_cksum_compare" + lappend files_skipped $current_source_dir/$m + } + } else { + set is_skip 1 + lappend files_skipped $current_source_dir/$m + } } else { set is_skip 1 puts stderr "Skipping file copy $m target $current_target_dir/$m already exists (use -overwrite all-targets to overwrite)" - #TODO! implement newer-targets older-targets + #TODO! implement newer-targets older-targets? (note ctimes/mtimes are unreliable - may not be worth implementing) lappend files_skipped $current_source_dir/$m } } @@ -1440,27 +1550,31 @@ namespace eval punkcheck { set ts_now [clock microseconds] set elapsed_us [expr {$ts_now - $ts_start}] - if {$store_cksums} { + #if {$store_source_cksums} { + #} - set install_records [dict get $filerec body] - set current_install_record [lindex $install_records end] - #change the tag from *-INPROGRESS to INSTALL-RECORD/SKIPPED - if {$is_skip} { - set tag INSTALL-SKIPPED - } else { - set tag INSTALL-RECORD - } - dict set current_install_record tag $tag - dict set current_install_record -elapsed_us $elapsed_us - lset install_records end $current_install_record - dict set filerec body $install_records - set filerec [punkcheck::recordlist::file_record_prune $filerec] ;#prune now that tag is finalized - if {!$has_filerec} { - #not found in original recordlist - append - lappend punkcheck_records $filerec - } else { - lset punkcheck_records $existing_filerec_posn $filerec - } + set install_records [dict get $filerec body] + set current_install_record [lindex $install_records end] + #change the tag from *-INPROGRESS to INSTALL-RECORD/SKIPPED + if {$is_skip} { + set tag INSTALL-SKIPPED + } else { + set tag INSTALL-RECORD + } + dict set current_install_record tag $tag + dict set current_install_record -elapsed_us $elapsed_us + if {[llength $new_tgt_cksum_info]} { + dict set current_install_record -targets_cksums [list [dict get $new_tgt_cksum_info cksum]] + dict set current_install_record -cksum_all_opts [dict get $new_tgt_cksum_info opts] + } + lset install_records end $current_install_record + dict set filerec body $install_records + set filerec [punkcheck::recordlist::file_record_prune $filerec] ;#prune now that tag is finalized + if {!$has_filerec} { + #not found in original recordlist - append + lappend punkcheck_records $filerec + } else { + lset punkcheck_records $existing_filerec_posn $filerec } } @@ -1536,11 +1650,10 @@ namespace eval punkcheck { #puts "subdirlist: $subdirlist" if {$CALLDEPTH == 0} { if {[llength $files_copied] || [llength $files_skipped]} { - puts stdout ">>>>>>>>>>>>>>>>>>>" + #puts stdout ">>>>>>>>>>>>>>>>>>>" set saveresult [punkcheck::save_records_to_file $punkcheck_records $punkcheck_file] - puts stdout "[dict get $saveresult recordcount] records saved as [dict get $saveresult linecount] lines to $punkcheck_file" - puts stdout "copied: [llength $files_copied] skipped: [llength $files_skipped]" - puts stdout ">>>>>>>>>>>>>>>>>>>" + puts stdout "punkcheck::install [dict get $saveresult recordcount] records saved as [dict get $saveresult linecount] lines to $punkcheck_file copied: [llength $files_copied] skipped: [llength $files_skipped]" + #puts stdout ">>>>>>>>>>>>>>>>>>>" } else { #todo - write db INSTALLER record if -debug true @@ -1551,10 +1664,30 @@ namespace eval punkcheck { } } - return [list files_copied $files_copied files_skipped $files_skipped sources_unchanged $sources_unchanged unpublish_paths_matched $unpublish_paths_matched punkcheck_records $punkcheck_records] + return [list files_copied $files_copied files_skipped $files_skipped sources_unchanged $sources_unchanged unpublish_paths_matched $unpublish_paths_matched punkcheck_records $punkcheck_records punkcheck_folder $punkcheck_folder srcdir $srcdir tgtdir $tgtdir] + } + proc summarize_install_resultdict {resultdict} { + set msg "" + if {[dict size $resultdict]} { + set copied [dict get $resultdict files_copied] + append msg "--------------------------" \n + append msg "[dict keys $resultdict]" \n + set tgtdir [dict get $resultdict tgtdir] + set checkfolder [dict get $resultdict punkcheck_folder] + append msg "Copied [llength $copied] files from [dict get $resultdict srcdir] to [dict get $resultdict tgtdir]" \n + foreach f $copied { + append msg "COPIED [punkcheck::lib::path_relative $checkfolder $f]" \n + append msg " TO $tgtdir" \n + } + append msg "[llength [dict get $resultdict sources_unchanged]] unchanged source files" \n + append msg "[llength [dict get $resultdict files_skipped]] skipped files" \n + append msg "--------------------------" \n + } + return $msg } namespace eval recordlist { + set pkg punkcheck namespace path ::punkcheck proc records_as_target_dict {record_list} { @@ -1590,8 +1723,8 @@ namespace eval punkcheck { } proc file_install_record_source_changes {install_record} { #reject INSTALLFAILED items ? - if {[dict get $install_record tag] ni [list "INSTALL-RECORD" "SKIPPED" "INSTALL-INPROGRESS" "MODIFY-INPROGRESS" "MODIFY-RECORD" "VIRTUAL-INPROGRESS" "VIRTUAL-RECORD" "DELETE-RECORD" "DELETE-INPROGRESS"]} { - error "file_install_record_source_changes bad file->install record: tag not INSTALL-RECORD|SKIPPED|INSTALL-INPROGRESS|MODIFY-RECORD|MODIFY-INPROGRESS|VIRTUAL-RECORD|VIRTUAL-INPROGRESS|DELETE-RECORD|DELETE-INPROGRESS" + if {[dict get $install_record tag] ni [list "QUERY-INPROGRESS" "INSTALL-RECORD" "INSTALL-SKIPPED" "INSTALL-INPROGRESS" "MODIFY-INPROGRESS" "MODIFY-RECORD" "MODIFY-SKIPPED" "VIRTUAL-INPROGRESS" "VIRTUAL-RECORD" "VIRTUAL-SKIPPED" "DELETE-RECORD" "DELETE-INPROGRESS" "DELETE-SKIPPED"]} { + error "file_install_record_source_changes bad install record: tag '[dict get $install_record tag]' not INSTALL-RECORD|SKIPPED|INSTALL-INPROGRESS|MODIFY-RECORD|MODIFY-INPROGRESS|VIRTUAL-RECORD|VIRTUAL-INPROGRESS|DELETE-RECORD|DELETE-INPROGRESS" } set source_list [dict_getwithdefault $install_record body [list]] set changed [list] @@ -1742,15 +1875,19 @@ namespace eval punkcheck { return $installer_record } proc file_record_latest_installrecord {file_record} { + tailcall file_record_latest_operationrecord INSTALL $file_record + } + proc file_record_latest_operationrecord {operation file_record} { + set operation [string toupper $operation] if {[dict get $file_record tag] ne "FILEINFO"} { - error "file_record_latest_installrecord bad file_record: tag not FILEINFO" + error "file_record_latest_operationrecord bad file_record: tag not FILEINFO" } if {![dict exists $file_record body]} { return [list] } set body_items [dict get $file_record body] foreach item [lreverse $body_items] { - if {[dict get $item tag] eq "INSTALL-RECORD"} { + if {[dict get $item tag] eq "$operation-RECORD"} { return $item } } @@ -1758,47 +1895,6 @@ namespace eval punkcheck { } - #dead code? - proc file_record_add_installrecordXXX {file_record install_record} { - if {[dict get $file_record tag] ne "FILEINFO"} { - error "file_record_add_installrecord bad file_record: tag not FILEINFO" - } - #disallow '-INPROGRESS' as it's not a final tag - if {[dict get $install_record tag] ni [list "INSTALL-RECORD" "SKIPPED"]} { - error "file_record_add_installrecord bad install_record: tag not INSTALL-RECORD" - } - set keep 3 - if {[dict exists $file_record -keep_installrecords]} { - set keep [dict get $file_record -keep_installrecords] - } - - if {[dict exists $file_record body]} { - set body_items [dict get $file_record body] - } else { - set body_items [list] - } - lappend body_items $install_record - set kept_body_items [list] - set kcount 0 - foreach item [lreverse $body_items] { - if {[dict get $item tag] eq "INSTALL-RECORD"} { - incr kcount - if {$keep < 0 || $kcount <= $keep} { - lappend kept_body_items $item - } - } else { - lappend kept_body_items $item - } - } - set kept_body_items [lreverse $kept_body_items] - - dict set file_record body $kept_body_items - return $file_record - - - } - - proc file_record_set_defaults {file_record} { if {[dict get $file_record tag] ne "FILEINFO"} { error "file_record_set_defaults bad file_record: tag not FILEINFO" @@ -1881,6 +1977,7 @@ namespace eval punkcheck { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready package provide punkcheck [namespace eval punkcheck { + set pkg punkcheck variable version set version 0.1.0 }] diff --git a/src/modules/shellfilter-0.1.8.tm b/src/modules/shellfilter-0.1.8.tm index 53abd15c..df5b34d7 100644 --- a/src/modules/shellfilter-0.1.8.tm +++ b/src/modules/shellfilter-0.1.8.tm @@ -11,7 +11,7 @@ namespace eval shellfilter::log { - variable allow_adhoc_tags 0 + variable allow_adhoc_tags 1 variable open_logs [dict create] #'tag' is an identifier for the log source. @@ -22,6 +22,7 @@ namespace eval shellfilter::log { if {![dict exists $settingsdict -tag]} { dict set settingsdict -tag $tag } else { + #review if {$tag ne [dict get $settingsdict -tag]} { error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[dict get $settingsdict -tag]' omit -tag, or supply same value" } @@ -36,6 +37,13 @@ namespace eval shellfilter::log { return $worker_tid } proc write {tag msg} { + upvar ::shellfilter::sources sourcelist + variable allow_adhoc_tags + if {!$allow_adhoc_tags} { + if {$tag ni $sourcelist} { + error "shellfilter::log::write tag '$tag' hasn't been initialised with a call to shellfilter::log::open $tag , and allow_adhoc_tags has been set false. use shellfilter::log::require_open false to allow adhoc tags" + } + } shellthread::manager::write_log $tag $msg } #write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written @@ -47,7 +55,8 @@ namespace eval shellfilter::log { shellthread::manager::unsubscribe [list $tag]; #workertid will be added back to free list if no tags remain subscribed } - #todo -implement + #review + #configure whether we can call shellfilter::log::write without having called open first proc require_open {{is_open_required {}}} { variable allow_adhoc_tags if {![string length $is_open_required]} { @@ -131,7 +140,7 @@ namespace eval shellfilter::ansi2 { overline 53 nooverline 55 frame 51 framecircle 52 noframe 54 } variable SGR_colour_map { - black 30 red 31 green 32 yellow 33 blue 4 purple 35 cyan 36 white 37 + black 30 red 31 green 32 yellow 33 blue 34 purple 35 cyan 36 white 37 Black 40 Red 41 Green 42 Yellow 43 Blue 44 Purple 45 Cyan 46 White 47 BLACK 100 RED 101 GREEN 102 YELLOW 103 BLUE 104 PURPLE 105 CYAN 106 WHITE 107 } @@ -1010,12 +1019,15 @@ namespace eval shellfilter::stack { set pipecount [dict size $pipelines] set tableprefix "$pipecount pipelines active\n" + foreach p [dict keys $pipelines] { + append tableprefix " " $p \n + } package require overtype #todo -verbose set table "" set ac1 [string repeat " " 15] - set ac2 [string repeat " " 32] - set ac3 [string repeat " " 80] + set ac2 [string repeat " " 42] + set ac3 [string repeat " " 70] append table "[overtype::left $ac1 channel-ident] " append table "[overtype::left $ac2 device-info] " append table "[overtype::left $ac3 stack-info]" @@ -1028,10 +1040,11 @@ namespace eval shellfilter::stack { foreach k [dict keys $pipelines $pipename] { set lc [dict get $pipelines $k device localchan] + set tid [dict get $pipelines $k device workertid] set col1 [overtype::left $ac1 $k] - set col2 [overtype::left $ac2 "localchan: $lc"] + set col2 [overtype::left $ac2 "localchan: $lc tid:$tid"] set stack [dict get $pipelines $k stack] if {![llength $stack]} { @@ -1148,15 +1161,24 @@ namespace eval shellfilter::stack { dict set pipelines $pipename [list] } #todo - proc delete {pipename} { - set pipeinfo [dict get $pipename] + proc delete {pipename {wait 0}} { + variable pipelines + set pipeinfo [dict get $pipelines $pipename] set deviceinfo [dict get $pipeinfo device] set localchan [dict get $deviceinfo localchan] unwind $pipename + #release associated thread + set tid [dict get $deviceinfo workertid] + if {$wait} { + thread::release -wait $tid + } else { + thread::release $tid + } chan close $localchan } + #review - proc name clarity is questionable. remove_stackitem? proc remove {pipename remove_id} { variable pipelines if {![dict exists $pipelines $pipename]} { @@ -2087,8 +2109,14 @@ namespace eval shellfilter { set worker_errorlist [list] set tidied_sources [list] set tidytag "logtidy" - set tid [::shellfilter::log::open $tidytag {-syslog 127.0.0.1:514}] - ::shellfilter::log::write $tidytag " logtidyuptags '$tags'" + + + # opening a thread or writing to a log/syslog close to possible process exit is probably not a great idea. + # we should ensure the thread already exists early on if we really need logging here. + # + #set tid [::shellfilter::log::open $tidytag {-syslog 127.0.0.1:514}] + #::shellfilter::log::write $tidytag " logtidyuptags '$tags'" + foreach s $sources { if {$s eq $tidytag} { continue @@ -2112,7 +2140,10 @@ namespace eval shellfilter { lappend remaining_sources $s } } - set sources [concat $remaining_sources $tidytag] + + #set sources [concat $remaining_sources $tidytag] + set sources $remaining_sources + #shellfilter::stack::unwind stdout #shellfilter::stack::unwind stderr return [list tidied $tidied_sources errors $worker_errorlist] @@ -2705,7 +2736,7 @@ namespace eval shellfilter { #} else { # #false alarm, or ? we've reached eof with data but didn't get an empty blocking read just prior # #Not known if this occurs - # #debugging output inline with data - don't leave enabled + # #debugging output inline with data - don't leave enabled # puts $outchan "!!!prev read didn't block: instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" #} } @@ -2747,15 +2778,17 @@ namespace eval shellfilter { } } trap CHILDSTATUS {result options} { set code [lindex [dict get $options -errorcode] 2] + set ::shellfilter::shellcommandvars($call_id,exitcode) $code if {$debug} { ::shellfilter::log::write $debugname " CHILD PROCESS EXITED with code: $code" } - set ::shellfilter::shellcommandvars($call_id,exitcode) $code } trap CHILDKILLED {result options} { #set code [lindex [dict get $options -errorcode] 2] #set ::shellfilter::shellcommandvars(%id%,exitcode) $code set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled" - ::shellfilter::log::write $debugname " CHILD PROCESS EXITED with result:'$result' options:'$options'" + if {$debug} { + ::shellfilter::log::write $debugname " CHILD PROCESS EXITED with result:'$result' options:'$options'" + } } finally { #puts stdout "HERE" @@ -2774,7 +2807,7 @@ namespace eval shellfilter { #todo - add ability to detect activity/data-flow and change timeout to only apply for period with zero data #e.g x hrs with no data(?) #reset timeout when data detected. - after $timeout [string map [list %w $waitvar %id% $call_id %wrerr% $wrerr %rdout% $rdout %rderr% $rderr %debug% $debug %debugname% $debugname] { + after $timeout [string map [list %w% $waitvar %id% $call_id %wrerr% $wrerr %rdout% $rdout %rderr% $rderr %debug% $debug %debugname% $debugname] { if {[info exists ::shellfilter::shellcommandvars(%id%,exitcode)]} { if {[set ::shellfilter::shellcommandvars(%id%,exitcode)] ne ""} { catch { chan close %wrerr% } @@ -2798,7 +2831,8 @@ namespace eval shellfilter { set code [lindex [dict get $options -errorcode] 2] #set code [dict get $options -code] #set ::shellfilter::shellcommandvars(%id%,exitcode) $code - set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled-timeout" + #set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled-timeout" + set ::shellfilter::shellcommandvars(%id%,exitcode) "childkilled-timeout" if {%debug%} { ::shellfilter::log::write %debugname% "(timeout) CHILDKILLED with code: $code" ::shellfilter::log::write %debugname% "(timeout) result:$result options:$options" @@ -2807,9 +2841,8 @@ namespace eval shellfilter { } catch { chan close %wrerr% } catch { chan close %rderr%} - } - set %w "timeout" + set %w% "timeout" } }] diff --git a/src/modules/shellrun-0.1.tm b/src/modules/shellrun-0.1.tm index 5988ec40..4295de4b 100644 --- a/src/modules/shellrun-0.1.tm +++ b/src/modules/shellrun-0.1.tm @@ -70,6 +70,7 @@ namespace eval shellrun { #maintenance: similar used in punk::ns & punk::winrun #todo - take runopts + aliases as args + #longopts must be passed as a single item ie --timeout=100 not --timeout 100 proc get_run_opts {arglist} { if {[catch { set callerinfo [info level -1] @@ -81,29 +82,49 @@ namespace eval shellrun { #we provide -nonewline even for 'run' even though run doesn't deliver stderr or stdout to the tcl return value #This is for compatibility with other runX commands, and the difference is also visible when calling from repl. - set known_runopts [list "-echo" "-e" "-nonewline" "-n" "-tcl"] - set aliases [list "-e" "-echo" "-echo" "-echo" "-n" "-nonewline" "-nonewline" "-nonewline" "-tcl" "-tcl"] ;#include map to self + set known_runopts [list "-echo" "-e" "-nonewline" "-n" "-tcl" "-debug"] + set known_longopts [list "--timeout"] + set known_longopts_msg "" + foreach lng $known_longopts { + append known_longopts_msg "${lng}=val " + } + set aliases [list "-e" "-echo" "-echo" "-echo" "-n" "-nonewline" "-nonewline" "-nonewline" "-tcl" "-tcl" "-debug" "-debug"] ;#include map to self set runopts [list] + set runoptslong [list] set cmdargs [list] + set idx_first_cmdarg [lsearch -not $arglist "-*"] - set runopts [lrange $arglist 0 $idx_first_cmdarg-1] + + set allopts [lrange $arglist 0 $idx_first_cmdarg-1] set cmdargs [lrange $arglist $idx_first_cmdarg end] - foreach o $runopts { - if {$o ni $known_runopts} { - error "$caller: Unknown runoption $o - known options $known_runopts" + foreach o $allopts { + if {[string match --* $o]} { + lassign [split $o =] flagpart valpart + if {$valpart eq ""} { + error "$caller: longopt $o seems to be missing a value - must be of form --option=value" + } + if {$flagpart ni $known_longopts} { + error "$caller: Unknown runoption $o - known options $known_runopts $known_longopts_msg" + } + lappend runoptslong $flagpart $valpart + } else { + if {$o ni $known_runopts} { + error "$caller: Unknown runoption $o - known options $known_runopts $known_longopts_msg" + } + lappend runopts [dict get $aliases $o] } } - set runopts [lmap o $runopts {dict get $aliases $o}] - return [list runopts $runopts cmdargs $cmdargs] + return [list runopts $runopts runoptslong $runoptslong cmdargs $cmdargs] } - + #todo - investigate cause of punk86 run hanging sometimes. An 'after 500' before exit in the called script fixes the issue. punk87 doesn't seem to be affected. proc run {args} { set_last_run_display [list] set splitargs [get_run_opts $args] set runopts [dict get $splitargs runopts] + set runoptslong [dict get $splitargs runoptslong] set cmdargs [dict get $splitargs cmdargs] if {"-nonewline" in $runopts} { @@ -115,7 +136,7 @@ namespace eval shellrun { #we leave stdout without imposed ansi colouring - because the source may be colourised #stderr might have source colouring - but it usually doesn't seem to, and the visual distiction of red stderr is very handy for the run command. #A further enhancement could be to detect well-known options such as --color and/or use a configuration for specific commands that have useful colourised stderr, - #but defaulting stderr to red is a pretty reasonable compromise. + #but defaulting stderr to red is a compromise. #Note that the other run commands, runout,runerr, runx don't emit in real-time - so for those commands there may be options to detect and/or post-process stdout and stderr. #TODO - fix. This has no effect because the repl adds an ansiwrap transform # what we probably want to do is 'aside' that transform for runxxx commands only. @@ -125,6 +146,12 @@ namespace eval shellrun { if {"-tcl" in $runopts} { dict set callopts -tclscript 1 } + if {"-debug" in $runopts} { + dict set callopts -debug 1 + } + if {[dict exists $runoptslong --timeout]} { + dict set callopts -timeout [dict get $runoptslong --timeout] ;#convert to single dash + } #--------------------------------------------------------------------------------------------- set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punk -inbuffering none -outbuffering none ] #--------------------------------------------------------------------------------------------- diff --git a/src/modules/shellthread-1.6.tm b/src/modules/shellthread-1.6.tm index 574dbda5..3c539d38 100644 --- a/src/modules/shellthread-1.6.tm +++ b/src/modules/shellthread-1.6.tm @@ -352,13 +352,22 @@ namespace eval shellthread::worker { #allow any client to terminate proc terminate {tidclient} { variable sock + variable fd variable client_ids if {$tidclient in $client_ids} { catch {close $sock} + catch {close $fd} set client_ids [list] - return 1 + #review use of thread::release -wait + #docs indicate deprecated for regular use, and that we should use thread::join + #however.. how can we set a timeout on a thread::join ? + #by telling the thread to release itself - we can wait on the thread::send variable + # This needs review - because it's unclear that -wait even works on self + # (what does it mean to wait for the target thread to exit if the target is self??) + thread::release -wait + return [thread::id] } else { - return 0 + return "" } } @@ -369,6 +378,7 @@ namespace eval shellthread::worker { namespace eval shellthread::manager { variable workers [dict create] variable worker_errors [list] + variable timeouts variable free_threads [list] #variable log_threads @@ -423,7 +433,7 @@ namespace eval shellthread::manager { set free_threads [lassign $free_threads tidworker] #todo - keep track of real ts_start of free threads... kill when too old set winfo [dict create tid $tidworker list_client_tids [list $tidclient] ts_start $ts_start ts_end_list [list]] - puts stderr "shellfilter::new_worker Re-using free worker thread: $tidworker with tag $sourcetag" + #puts stderr "shellfilter::new_worker Re-using free worker thread: $tidworker with tag $sourcetag" dict set workers $sourcetag $winfo return $tidworker } @@ -604,11 +614,58 @@ namespace eval shellthread::manager { return $taginfo_list } + #finalisation + proc shutdown_free_threads {{timeout 2500}} { + variable free_threads + if {![llength $free_threads]} { + return + } + upvar ::shellthread::manager::timeouts timeoutarr + if {[info exists timeoutarr(shutdown_free_threads)]} { + #already called + return false + } + #set timeoutarr(shutdown_free_threads) waiting + #after $timeout [list set timeoutarr(shutdown_free_threads) timed-out] + set ::shellthread::waitfor waiting + after $timeout [list set ::shellthread::waitfor] + + set waiting_for [list] + set ended [list] + set timedout 0 + foreach tid $free_threads { + if {[thread::exists $tid]} { + lappend waiting_for $tid + #thread::send -async $tid [list shellthread::worker::terminate [thread::id]] timeoutarr(shutdown_free_threads) + thread::send -async $tid [list shellthread::worker::terminate [thread::id]] ::shellthread::waitfor + } + } + if {[llength $waiting_for]} { + for {set i 0} {$i < [llength $waiting_for]} {incr i} { + vwait ::shellthread::waitfor + if {$::shellthread::waitfor eq "timed-out"} { + set timedout 1 + break + } else { + lappend ended $::shellthread::waitfor + } + } + } + set free_threads [list] + return [dict create existed $waiting_for ended $ended timedout $timedout] + } + + #TODO - important. + #REVIEW! + #since moving to the unsubscribe mechansm - close_worker $source isn't being called + # - we need to set a limit to the number of free threads and shut down excess when detected during unsubscription + #instruction to shut-down the thread that has this source. #instruction to shut-down the thread that has this source. proc close_worker {source {timeout 2500}} { variable workers variable worker_errors variable free_threads + upvar ::shellthread::manager::timeouts timeoutarr set ts_now [clock micros] #puts stderr "close_worker $source" if {[dict exists $workers $source]} { @@ -639,6 +696,8 @@ namespace eval shellthread::manager { if {[thread::exists $tidworker]} { #puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source still running.. terminating" + + #review - timeoutarr is local var (?) set timeoutarr($source) 0 after $timeout [list set timeoutarr($source) 2] @@ -676,7 +735,6 @@ namespace eval shellthread::manager { #worker errors only available for a source after close_worker called on that source #It is possible for there to be multiple entries for a source because new_worker can be called multiple times with same sourcetag, - # e.g if a thread proc get_and_clear_errors {source} { variable worker_errors set source_errors [lsearch -all -inline -index 0 $worker_errors $source] diff --git a/src/modules/zzzload-999999.0a1.0.tm b/src/modules/zzzload-999999.0a1.0.tm index 567ff708..7a872f0f 100644 --- a/src/modules/zzzload-999999.0a1.0.tm +++ b/src/modules/zzzload-999999.0a1.0.tm @@ -23,12 +23,40 @@ package require Thread # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval zzzload { - variable loader_tid ;#thread id - set loader_tid [thread::create -preserved] + variable loader_tid "" ;#thread id + proc stacktrace {} { + set stack "Stack trace:\n" + for {set i 1} {$i < [info level]} {incr i} { + set lvl [info level -$i] + set pname [lindex $lvl 0] + append stack [string repeat " " $i]$pname + + if {![catch {info args $pname} pargs]} { + foreach value [lrange $lvl 1 end] arg $pargs { + + if {$value eq ""} { + if {$arg != 0} { + info default $pname $arg value + } + } + append stack " $arg='$value'" + } + } else { + append stack " !unknown vars for $pname" + } + append stack \n + } + return $stack + } proc pkg_require {pkgname args} { variable loader_tid + if {$loader_tid eq ""} { + set loader_tid [thread::create -joinable -preserved] + } if {![tsv::exists zzzload_pkg $pkgname]} { + #puts stderr "zzzload pkg_require $pkgname" + #puts [stacktrace] tsv::set zzzload_pkg $pkgname "loading" tsv::set zzzload_pkg_mutex $pkgname [thread::mutex create] set cond [thread::cond create] @@ -62,6 +90,14 @@ namespace eval zzzload { return $pkgstate } } + proc shutdown {} { + variable loader_tid + if {[thread::exists $loader_tid]} { + thread::release $loader_tid + thread::join $loader_tid + set loader_tid "" + } + } } diff --git a/src/punk86.vfs/lib/app-punk/repl.tcl b/src/punk86.vfs/lib/app-punk/repl.tcl index 6ecd6e45..790a8147 100644 --- a/src/punk86.vfs/lib/app-punk/repl.tcl +++ b/src/punk86.vfs/lib/app-punk/repl.tcl @@ -72,6 +72,7 @@ if {[llength $currentdir_modules]} { #puts stdout "$::auto_path" package require Thread +catch {package require tcllibc} #These are strong dependencies # - the repl requires Threading and punk,shellfilter,shellrun to call and display properly. # tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list diff --git a/src/punk86.vfs/lib/app-shellspy/shellspy.tcl b/src/punk86.vfs/lib/app-shellspy/shellspy.tcl index 6711e305..1a578989 100644 --- a/src/punk86.vfs/lib/app-shellspy/shellspy.tcl +++ b/src/punk86.vfs/lib/app-shellspy/shellspy.tcl @@ -26,6 +26,21 @@ # package provide app-shellspy 1.0 +if 0 { + rename ::package ::package_orig + proc package {args} { + if {[lindex $args 0] eq "require"} { + if {[lindex $args 1] eq "twapi"} { + puts stderr "-------------------- loading twapi -------------" + } else { + puts stderr "-- loading [lindex $args 1] --" + } + + } + tailcall ::package_orig {*}$args + } +} + #a test for windows #fconfigure stdin -encoding utf-16le @@ -84,6 +99,7 @@ if {[file extension $arg1] in [list .tCl]} { #lappend auto_path c:/tcl/lib/tcllib1.20 +catch {package require tcllibc} package require Thread #NOTE: tm package index will probably already have been created so we must use 'package forget' to restrict to current tcl::tm::list path @@ -127,7 +143,9 @@ namespace eval shellspy { #set id_ansistrip [shellfilter::stack::add stderr ansistrip -settings {}] #set id_ansistrip [shellfilter::stack::add stdout ansistrip -settings {}] - lassign [shellfilter::redir_output_to_log "SPY"] id_stdout_redir id_stderr_redir + #redir on the shellfilter stack with no log or syslog specified acts to suppress output of stdout & stderr. + #todo - fix shellfilter code to make this noop more efficient (avoid creating corresponding logging thread and filter?) + lassign [shellfilter::redir_output_to_log "SUPPRESS"] id_stdout_redir id_stderr_redir ### @@ -326,6 +344,8 @@ namespace eval shellspy { set params [dict merge $params [get_channel_config $::testconfig]] ;#working: 5 unbuffered, 6 linebuffered + dict set params -debug 1 + dict set params -timeout 1000 #set exitinfo [shellfilter::run [list pwsh -nologo -noprofile -c {*}$args] -debug 1] @@ -392,11 +412,12 @@ namespace eval shellspy { #shellfilter::stack::remove stdout $id_out + shellfilter::log::write $shellspy_status_log "do_in_cmdshell raw exitinfo: $exitinfo" if {[lindex $exitinfo 0] eq "exitcode"} { #exit [lindex $exitinfo 1] - shellfilter::log::write $shellspy_status_log "do_in_cmdshell returning $exitinfo" + #shellfilter::log::write $shellspy_status_log "do_in_cmdshell returning $exitinfo" #puts stderr "do_in_cmdshell returning $exitinfo" } return $exitinfo @@ -514,21 +535,22 @@ namespace eval shellspy { - set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] + #set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] #todo - use glob to check capitalisation of file tail (.TCL vs .tcl .Tcl etc) set exitinfo [shellfilter::run [concat [auto_execok $scriptbin] $scriptpath $args] {*}$params] + shellfilter::log::write $shellspy_status_log "do_script_process exitinfo: $exitinfo" - shellfilter::stack::remove stderr $id_err + #shellfilter::stack::remove stderr $id_err - if {[lindex $exitinfo 0] eq "exitcode"} { - shellfilter::log::write $shellspy_status_log "do_script_process returning $exitinfo" - } - if {[dict exists $exitinfo errorCode]} { - exit [dict get $exitinfo $errorCode] - } + #if {[lindex $exitinfo 0] eq "exitcode"} { + # shellfilter::log::write $shellspy_status_log "do_script_process returning $exitinfo" + #} + #if {[dict exists $exitinfo errorCode]} { + # exit [dict get $exitinfo $errorCode] + #} return $exitinfo } proc do_script {scriptname replwhen args} { @@ -604,7 +626,22 @@ source [file normalize $scriptname] # shellfilter::log::write $shellspy_status_log "do_script returning $exitinfo" #} - shellfilter::log::write $shellspy_status_log "do_script returning $exitinfo" + shellfilter::log::write $shellspy_status_log "do_script raw exitinfo: $exitinfo" + if {[dict exists $exitinfo errorInfo]} { + #strip out the irrelevant info from the errorInfo - we don't want info beyond 'invoked from within' as this is just plumbing related to the script sourcing + set stacktrace [string map [list \r\n \n] [dict get $exitinfo errorInfo]] + set output "" + set tracelines [split $stacktrace \n] + foreach ln $tracelines { + if {[string match "*invoked from within*" $ln]} { + break + } + append output $ln \n + } + set output [string trimright $output \n] + dict set exitinfo errorInfo $output + shellfilter::log::write $shellspy_status_log "do_script simplified exitinfo: $exitinfo" + } return $exitinfo } @@ -650,12 +687,9 @@ source [file normalize $scriptname] dict set params -debug 0 - set params [dict merge $params [get_channel_config $::testconfig]] - set id_out [shellfilter::stack::add stdout towindows -action sink-aside-locked -junction 1 -settings {}] - dict set params -teehandle shellspy ;#shellspyout shellspyerr must exist set exitinfo [shellfilter::run [concat wsl -d $dist -e [shellescape $args]] {*}$params] @@ -792,15 +826,17 @@ source [file normalize $scriptname] -values $::argv ] - + set is_call_error 0 + set arglist [list] ;#processed args result - contains dispatch info etc. if {[catch { set arglist [check_flags {*}$argdefinitions] - } errMsg]} { + } callError]} { puts -nonewline stderr "|shellspy-stderr> ERROR during command dispatch\n" - puts -nonewline stderr "|shellspy-stderr> $errMsg\n" + puts -nonewline stderr "|shellspy-stderr> $callError\n" puts -nonewline stderr "|shellspy-stderr> [set ::errorInfo]\n" - shellfilter::log::write $shellspy_status_log "check_flags error: $errMsg" + shellfilter::log::write $shellspy_status_log "check_flags error: $callError" + set is_call_error 1 } else { shellfilter::log::write $shellspy_status_log "check_flags result: $arglist" } @@ -820,28 +856,119 @@ source [file normalize $scriptname] #don't open more logs.. #puts stdout ">$tidyinfo" + #lassign [shellfilter::redir_output_to_log "SUPPRESS"] id_stdout_redir id_stderr_redir + shellfilter::stack::remove stderr $id_stderr_redir + shellfilter::stack::remove stdout $id_stdout_redir #shellfilter::log::write $shellspy_status_log "logtidyup -done- $tidyinfo" - set errorlist [dict get $tidyinfo errors] - if {[llength $errorlist]} { - foreach err $errorlist { - puts -nonewline stderr "|shellspy-final> worker-error-set $err\n" - } + catch { + set errorlist [dict get $tidyinfo errors] + if {[llength $errorlist]} { + foreach err $errorlist { + puts -nonewline stderr "|shellspy-final> worker-error-set $err\n" + } + } } - puts stdout "shellspy -done-" - #shellfilter::log::write $shellspy_status_log "shellspy -done-" - flush stdout + + #puts stdout "shellspy -done1-" + #flush stdout + #shellfilter::log::write $shellspy_status_log "shellspy -done-" + if {[catch { shellfilter::logtidyup $shellspy_status_log + #puts stdout "shellspy logtidyup done" + #flush stdout } errMsg]} { + puts stdout "shellspy logtidyup error $errMsg" + flush stdout shellfilter::log::open shellspy-final {-tag shellspy-final -syslog 127.0.0.1:514} shellfilter::log::write shellspy-final "FINAL logtidyup error $errMsg\n [set ::errorInfo]" - after 200 - + after 100 + } + #puts [shellfilter::stack::status shellspyout] + #puts [shellfilter::stack::status shellspyerr] + + #sample dispatch member of $arglist + #dispatch { + # tclscript { + # command {shellspy::do_script %matched% no_repl} + # matched stdout.tcl arguments {} raw {} dispatchtype raw + # asdispatched {shellspy::do_script stdout.tcl no_repl} + # result {result {}} + # error {} + # } + #} + # or + #dispatch { + # tclscript { + # command xxx + # matched error.tcl arguments {} raw {} dispatchtype raw + # asdispatched {shellspy::do_script error.tcl no_repl} + # result { + # error {This is the error} + # errorCode NONE + # errorInfo This\ is\ the\ error\n\ etc + # } + # error {} + # } + #} + + + shellfilter::stack::delete shellspyout + shellfilter::stack::delete shellspyerr + set free_info [shellthread::manager::shutdown_free_threads] + #puts stdout $free_info + #flush stdout + if {[package provide zzzload] ne ""} { + #puts "zzzload::loader_tid [set ::zzzload::loader_tid]" + zzzload::shutdown + } + #puts stdout "threads: [thread::names]" + #flush stdout + #puts stdout "calling release on remaining threads" + foreach tid [thread::names] { + thread::release $tid + } + #puts stdout "threads: [thread::names]" + #flush stdout + + + set colour ""; set reset "" + if {$is_call_error} { + catch { + set colour [punk::ansi::a+ yellow bold underline]; set reset [punk::ansi::a] + } + puts stderr $colour$callError$reset + flush stderr + exit 1 + } else { + if {[dict exists $arglist dispatch tclscript result errorInfo]} { + catch { + set colour [punk::ansi::a+ yellow bold]; set reset [punk::ansi::a] + } + set err [dict get $arglist dispatch tclscript result errorInfo] + if {$err ne ""} { + puts stderr $colour$err$reset + flush stderr + exit 1 + } + } } + + # -- --- --- + # -- a deadlock hack. after 500 is not enough, after 1000 seems to work. + #after 1000 + #after 500 + # -- --- --- + + if {[dict exists $arglist errorCode]} { + exit [dict get $arglist errorCode] + } + #if we call exit - package require Tk scripts will exit prematurely + #review #exit 0 } diff --git a/src/runtime/mapvfs.config b/src/runtime/mapvfs.config index 7080d735..f21d57e2 100644 --- a/src/runtime/mapvfs.config +++ b/src/runtime/mapvfs.config @@ -1,6 +1,10 @@ -#single line per runtime executable. Name of runtime followed by list of .vfs folders with path relative to src folder. -#if runtime has no entry - it will only match a .vfs folder with a matching filename e.g runtime1.exe runtime1.vfs -tclkit86bi.exe punk86.vfs -tclkit87a5bawt.exe punk86.vfs -#tclkit86bi.exe vfs_windows/punk86win.vfs - +#single line per runtime executable. Name of runtime followed by list of .vfs folders with path relative to src folder. +#if runtime has no entry - it will only match a .vfs folder with a matching filename e.g runtime1.exe runtime1.vfs +#Use a runtime with a name of dash (-) to build a .kit file from the .vfs folder using no runtime +#e.g +#- myproject.vfs +#- punk86.vfs +tclkit86bi.exe punk86.vfs +#tclkit87a5bawt.exe punk86.vfs +#tclkit86bi.exe vfs_windows/punk86win.vfs +