diff --git a/src/make.tcl b/src/make.tcl index eca518ab..174c1f25 100644 --- a/src/make.tcl +++ b/src/make.tcl @@ -331,12 +331,6 @@ foreach src_module_dir $source_module_folderlist { # ---------------------------------------- -set vfs_folders [glob -nocomplain -dir $sourcefolder -types d -tail *.vfs] -if {![llength $vfs_folders]} { - puts stdout "No .vfs folders found at '$sourcefolder' - no kits to build" - puts stdout " -done- " - exit 0 -} set buildfolder [punk::mix::cli::lib::get_build_workdir $sourcefolder] if {$buildfolder ne "$sourcefolder/_build"} { @@ -346,7 +340,7 @@ if {$buildfolder ne "$sourcefolder/_build"} { } -#find runtime - only supports one for now.. REVIEW +#find runtimes set rtfolder $sourcefolder/runtime set runtimes [glob -nocomplain -dir $rtfolder -types {f x} -tail *] if {![llength $runtimes]} { @@ -360,12 +354,75 @@ if {[catch {exec sdx help} errM]} { exit 1 } +# -- --- --- --- --- --- --- --- --- --- +#load mapvfs.config file (if any) in runtime folder to map runtimes to vfs folders. +#build a dict keyed on runtime executable name. +#If no mapfile (or no mapfile entry for that runtime) - the runtime will be paired with a matching .vfs folder in src folder. e.g punk.exe to src/punk.vfs +#If vfs folders or runtime executables which are explicitly listed in the mapfile don't exist - warn on stderr - but continue. if such nonexistants found; prompt user for whether to continue or abort. +set mapfile $rtfolder/mapvfs.config +set runtime_vfs_map [dict create] +set vfs_runtime_map [dict create] +if {[file exists $mapfile]} { + set fdmap [open $mapfile r] + fconfigure $fdmap -translation binary + set mapdata [read $fdmap] + close $fdmap + set mapdata [string map [list \r\n \n] $mapdata] + set missing [list] + foreach ln [split $mapdata \n] { + set ln [string trim $ln] + if {$ln eq "" || [string match #* $ln]} { + continue + } + set vfspaths [lassign $ln runtime] + if {[string match *.exe $runtime]} { + #.exe is superfluous but allowed + #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 + } + foreach vfs $vfspaths { + if {![file isdirectory [file join $sourcefolder $vfs]]} { + puts stderr "WARNNING: Missing vfs folder [file join $sourcefolder $vfs] specified in mapvfs.config for runtime $runtime" + lappend missing $vfs + } + dict lappend vfs_runtime_map $vfs $runtime + } + if {[dict exists $runtime_vfs_map $runtime]} { + puts stderr "CONFIG FILE ERROR. runtime: $runtime was specified more than once in $mapfile." + exit 3 + } + dict set runtime_vfs_map $runtime $vfspaths + } + if {[llength $missing]} { + puts stderr "WARNING [llength $missing] missing items from $mapfile. (TODO - prompt user to continue/abort)" + foreach m $missing { + puts stderr " $m" + } + puts stderr "continuing..." + } +} +# -- --- --- --- --- --- --- --- --- --- -#if {[llength $runtimes] > 1} { -# puts stderr "Found multiple runtimes in $rtfolder ($runtimes) - unable to proceed - currently limited to one." -# exit 3 -#} - +set vfs_folders [glob -nocomplain -dir $sourcefolder -types d -tail *.vfs] +#add any extra .vfs folders found in runtime/mapvfs.config file (e.g myotherruntimes/something.vfs) +foreach vfs [dict keys $vfs_runtime_map] { + if {$vfs ni $vfs_folders} { + lappend vfs_folders $vfs + } +} +if {![llength $vfs_folders]} { + puts stdout "No .vfs folders found at '$sourcefolder' - no kits to build" + puts stdout " -done- " + exit 0 +} 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 @@ -373,7 +430,7 @@ set installername "make.tcl" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- #set runtimefile [lindex $runtimes 0] foreach runtimefile $runtimes { - #runtimefile e.g tclkit86bi.exe + #runtimefile e.g tclkit86bi.exe on windows tclkit86bi on other platforms #sdx *may* be pointed to use the runtime we use to build the kit, or the user may manually use this runtime if they don't have tclsh #sdx will complain if the same runtime is used for the shell as is used in the -runtime argument - so we make a copy (REVIEW) @@ -395,7 +452,7 @@ foreach runtimefile $runtimes { 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]] - if {[llength [dict get $changed_unchanged changed]]} { + if {[llength [dict get $changed_unchanged changed]] || ![file exists $buildfolder/build_$runtimefile]} { set file_record [punkcheck::installfile_started_install $basedir $file_record] # -- --- --- --- --- --- puts stdout "Copying runtime from $rtfolder/$runtimefile to $buildfolder/build_$runtimefile" @@ -412,7 +469,11 @@ foreach runtimefile $runtimes { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - +# +# loop over vfs_folders and for each one, loop over configured (or matching) runtimes - build with sdx if source .vfs or source runtime exe has changed. +# we are using punkcheck to install result to buildfolder so we create a .punkcheck file at the target folder to store metadata. +# punkcheck allows us to not rely purely on timestamps (which may be unreliable) +# set startdir [pwd] puts stdout "Found [llength $vfs_folders] .vfs folders - building executable for each..." cd [file dirname $buildfolder] @@ -420,6 +481,7 @@ cd [file dirname $buildfolder] #a hash of full tree file & dir mtime may be more reasonable - but it remains to be seen if just tar & checksum is any/much slower. #Simply rebuilding all the time may be close the speed of detecting change anyway - and almost certainly much faster when there is a change. #Using first mtime encountered that is later than target is another option - but likely to be highly variable in speed. Last file in the tree could happen to be the latest, and this mechanism doesn't handle build on reversion to older source. +set exe_names_seen [list] foreach vfs $vfs_folders { set vfsname [file rootname $vfs] @@ -431,157 +493,191 @@ foreach vfs $vfs_folders { set config [dict create\ -make-step build_vfs\ ] - lassign [punkcheck::start_installer_event $basedir/.punkcheck $installername $sourcefolder $buildfolder $config] _eventid punkcheck_eventid _recordset record_list - - set target_relpath [punkcheck::lib::path_relative $basedir $buildfolder/$vfsname.exe] - set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] - # -- --- --- --- --- --- - set source_relpath [punkcheck::lib::path_relative $basedir $sourcefolder/$vfs] - 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]] - if {[llength [dict get $changed_unchanged changed]]} { - set file_record [punkcheck::installfile_started_install $basedir $file_record] - # -- --- --- --- --- --- - - if {[file exists $buildfolder/$vfsname]} { - puts stderr "deleting existing $buildfolder/$vfsname" - file delete $sourcefolder/_build/$vfsname + set runtimes [list] + if {[dict exists $vfs_runtime_map $vfs]} { + set runtimes [dict get $vfs_runtime_map $vfs] ;#map dict is unsuffixed (.exe stripped or was not present) + if {"windows" eq $::tcl_platform(platform)} { + set runtimes_raw $runtimes + set runtimes [list] + foreach rt $runtimes_raw { + if {![string match *.exe $rt]} { + set rt $rt.exe + } + lappend runtimes $rt + } } + } else { + #only match this vfs to a correspondingly named runtime if there was no explicit entry for that runtime + set matchrt [file rootname [file tail $vfs]] ;#e.g project.vfs -> project + if {![dict exists $runtime_vfs_map $matchrt]} { + if {"windows" eq $::tcl_platform(platform)} { + if {[file exists $rtfolder/$matchrt.exe]} { + lappend runtimes $matchrt.exe + } + } else { + lappend runtimes $matchrt + } + } + } + #assert $runtimes is a list of executable names suffixed with .exe if on windows - whether or not specified with .exe in the mapvfs.config - puts stdout "building $vfsname with sdx.. vfsdir:$vfs cwd: [pwd]" + foreach rtname $runtimes { - if {[catch { - exec sdx wrap $buildfolder/$vfsname -vfs $sourcefolder/$vfs -runtime $buildfolder/buildruntime.exe -verbose - } result]} { - puts stderr "sdx wrap _build/$vfsname -vfs $sourcefolder/$vfs -runtime $buildfolder/buildruntime.exe -verbose failed with msg: $result" + #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 } else { - puts stdout "ok - finished sdx" - set separator [string repeat = 40] - puts stdout $separator - puts stdout $result - puts stdout $separator + set targetexe $vfsname } - - if {![file exists $buildfolder/$vfsname]} { - puts stderr "|err> build didn't seem to produce output at $sourcefolder/_build/$vfsname" - exit 2 + if {$targetexe in $exe_names_seen} { + #more than one runtime for this .vfs + set targetexe ${vfsname}_$rtname } + lappend exe_names_seen $targetexe + lassign [punkcheck::start_installer_event $basedir/.punkcheck $installername $sourcefolder $buildfolder $config] _eventid punkcheck_eventid _recordset record_list - + set target_relpath [punkcheck::lib::path_relative $basedir $buildfolder/$targetexe] + set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] # -- --- --- --- --- --- - set file_record [punkcheck::installfile_finished_install $basedir $file_record] - } else { - set skipped_vfs_build 1 - puts stderr "." - puts stdout "Skipping build for vfs $vfs - no change detected" - set file_record [punkcheck::installfile_skipped_install $basedir $file_record] - } - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set source_relpath [punkcheck::lib::path_relative $basedir $sourcefolder/$vfs] + set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] + # -- --- --- --- --- --- + set source_relpath [punkcheck::lib::path_relative $basedir $buildfolder/build_$rtname] + 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]] + if {[llength [dict get $changed_unchanged changed]] || ![file exists $buildfolder/$targetexe]} { + #source .vfs folder has changes + set file_record [punkcheck::installfile_started_install $basedir $file_record] + # -- --- --- --- --- --- + + #use + if {[file exists $buildfolder/$vfsname.new]} { + puts stderr "deleting existing $buildfolder/$vfsname.new" + file delete $buildfolder/$vfsname.new + } + puts stdout "building $vfsname with sdx.. vfsdir:$vfs cwd: [pwd]" - if {!$skipped_vfs_build} { - - if {$::tcl_platform(platform) eq "windows"} { - set pscmd "tasklist" - } 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] + if {[catch { + exec sdx wrap $buildfolder/$vfsname.new -vfs $sourcefolder/$vfs -runtime $buildfolder/build_$rtname -verbose + } result]} { + puts stderr "sdx wrap $buildfolder/$vfsname.new -vfs $sourcefolder/$vfs -runtime $buildfolder/build_$rtname -verbose failed with msg: $result" + } else { + puts stdout "ok - finished sdx" + set separator [string repeat = 40] + puts stdout $separator + puts stdout $result + puts stdout $separator + } + + if {![file exists $buildfolder/$vfsname.new]} { + puts stderr "|err> build didn't seem to produce output at $sourcefolder/_build/$vfsname.new" + exit 2 + } + + # -- --- --- + if {$::tcl_platform(platform) eq "windows"} { + set pscmd "tasklist" + } 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] + } 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 + puts stderr "(try '[info script] -k' option to force kill)" + 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 {$::tcl_platform(platform) eq "windows"} { - set targetexe ${vfsname}.exe - } else { - set targetexe $vfsname - } - if {[file exists $buildfolder/$targetexe]} { - puts stderr "deleting existing $buildfolder/$targetexe" - if {[catch { - file delete $buildfolder/$targetexe - } msg]} { - puts stderr "Failed to delete $buildfolder/$targetexe" - exit 4 + if {[file exists $buildfolder/$targetexe]} { + puts stderr "deleting existing $buildfolder/$targetexe" + if {[catch { + file delete $buildfolder/$targetexe + } msg]} { + puts stderr "Failed to delete $buildfolder/$targetexe" + exit 4 + } } - } - if {$::tcl_platform(platform) eq "windows"} { - file rename $buildfolder/$vfsname $buildfolder/${vfsname}.exe - } + file rename $buildfolder/$vfsname.new $buildfolder/$targetexe + # -- --- --- --- --- --- + set file_record [punkcheck::installfile_finished_install $basedir $file_record] - after 200 - set deployment_folder [file dirname $sourcefolder]/bin - file mkdir $deployment_folder + after 200 + set deployment_folder [file dirname $sourcefolder]/bin + file mkdir $deployment_folder - if {[file exists $deployment_folder/$targetexe]} { - puts stderr "deleting existing deployed at $deployment_folder/$targetexe" - if {[catch { - file delete $deployment_folder/$targetexe - } errMsg]} { - puts stderr "deletion of deployed version at $deployment_folder/$targetexe failed: $errMsg" - exit 5 + if {[file exists $deployment_folder/$targetexe]} { + puts stderr "deleting existing deployed at $deployment_folder/$targetexe" + if {[catch { + file delete $deployment_folder/$targetexe + } errMsg]} { + puts stderr "deletion of deployed version at $deployment_folder/$targetexe failed: $errMsg" + exit 5 + } } - } + puts stdout "copying.." + puts stdout "$buildfolder/$targetexe" + puts stdout "to:" + puts stdout "$deployment_folder/$targetexe" + after 500 + file copy $buildfolder/$targetexe $deployment_folder/$targetexe - - puts stdout "copying.." - puts stdout "$buildfolder/$targetexe" - puts stdout "to:" - puts stdout "$deployment_folder/$targetexe" - after 500 - file copy $buildfolder/$targetexe $deployment_folder/$targetexe - } + } else { + set skipped_vfs_build 1 + puts stderr "." + puts stdout "Skipping build for vfs $vfs - no change detected" + set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + } + } ;#end foreach rtname in runtimes + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- } cd $startdir diff --git a/src/modules/oolib-0.1.1.tm b/src/modules/oolib-0.1.1.tm new file mode 100644 index 00000000..a9214267 --- /dev/null +++ b/src/modules/oolib-0.1.1.tm @@ -0,0 +1,197 @@ +#JMN - api should be kept in sync with package patternlib where possible +# +package provide oolib [namespace eval oolib { + variable version + set version 0.1.1 +}] + +namespace eval oolib { + oo::class create collection { + variable o_data ;#dict + variable o_alias + constructor {} { + set o_data [dict create] + } + method info {} { + return [dict info $o_data] + } + method count {} { + return [dict size $o_data] + } + method isEmpty {} { + expr {[dict size $o_data] == 0} + } + method names {{globOrIdx {}}} { + if {[llength $globOrIdx]} { + if {[string is integer -strict $globOrIdx]} { + set idx $globOrIdx + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + if {[catch {lindex [dict keys $o_data] $idx} result]} { + error "[self object] no such index : '$idx'" + } else { + return $result + } + } else { + #glob + return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] + } + } else { + return [dict keys $o_data] + } + } + #like names but without globbing + method keys {} { + dict keys $o_data + } + method key {{posn 0}} { + if {$posn < 0} { + set posn "end-[expr {abs($posn + 1)}]" + } + if {[catch {lindex [dict keys $o_data] $posn} result]} { + error "[self object] no such index : '$posn'" + } else { + return $result + } + } + method hasKey {key} { + dict exists $o_data $key + } + method get {} { + return $o_data + } + method items {} { + return [dict values $o_data] + } + method item {key} { + if {[string is integer -strict $key]} { + if {$key >= 0} { + set valposn [expr {(2*$key) +1}] + return [lindex $o_data $valposn] + } else { + set key "end-[expr {abs($key + 1)}]" + return [lindex $o_data $key] + #return [lindex [dict keys $o_data] $key] + } + } + if {[dict exists $o_data $key]} { + return [dict get $o_data $key] + } + } + #inverse lookup + method itemKeys {value} { + set value_indices [lsearch -all [dict values $o_data] $value] + set keylist [list] + foreach i $value_indices { + set idx [expr {(($i + 1) *2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } + method search {value args} { + set matches [lsearch {*}$args [dict values $o_data] $value] + if {"-inline" in $args} { + return $matches + } else { + set keylist [list] + foreach i $matches { + set idx [expr {(($i + 1) *2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } + } + #review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? + method alias {newAlias existingKeyOrAlias} { + if {[string is integer -strict $newAlias]} { + error "[self object] collection key alias cannot be integer" + } + if {[string length $existingKeyOrAlias]} { + set o_alias($newAlias) $existingKeyOrAlias + } else { + unset o_alias($newAlias) + } + } + method aliases {{key ""}} { + if {[string length $key]} { + set result [list] + foreach {n v} [array get o_alias] { + if {$v eq $key} { + lappend result $n $v + } + } + return $result + } else { + return [array get o_alias] + } + } + #if the supplied index is an alias, return the underlying key; else return the index supplied. + method realKey {idx} { + if {[catch {set o_alias($idx)} key]} { + return $idx + } else { + return $key + } + } + method add {value key} { + if {[string is integer -strict $key]} { + error "[self object] collection key must not be an integer. Use another structure if integer keys required" + } + if {[dict exists $o_data $key]} { + error "[self object] col_processors object error: key '$key' already exists in collection" + } + dict set o_data $key $value + return [expr {[dict size $o_data] - 1}] ;#return index of item + } + method remove {idx {endRange ""}} { + if {[string length $endRange]} { + error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" + } + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx+1)}]" + } + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + if {$posn < 0} { + error "[self object] no such index: '$idx' in this collection" + } + } + dict unset o_data $key + return + } + method clear {} { + set o_data [dict create] + return + } + method reverse {} { + 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-0.1.tm b/src/modules/punk-0.1.tm index 5cf5f1b5..8fbf6744 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -6,6 +6,7 @@ namespace eval punk { package require zzzload zzzload::pkg_require twapi + catch {package require vfs} ;#attempt load now so we can use faster 'package provide' to test existence later } @@ -171,7 +172,7 @@ namespace eval punk { if {$loader in [list failed loading]} { puts stderr "Unexpected problem during thread-load of pkg twapi - zzload::pkg_wait returned $loader" } - if {![catch {package require twapi}]} { + if {[package provide twapi] ne ""} { set has_twapi 1 } } @@ -4636,7 +4637,8 @@ namespace eval punk { set r $data for {set i 0} {$i < [llength $args]} {incr i} { set e [lindex $args $i] - if {[catch {llength $e} seglen]} { + #review: string is list is as slow as catch {llength $e} - and also affects ::errorInfo unlike other string is commands. bug/enhancement report? + if {![string is list $e]} { #not a list - assume script and run anyway set r [apply [list {data} $e] $r] } else { @@ -5130,7 +5132,7 @@ namespace eval punk { proc dirlist {{location ""}} { set contents [dirfiles_dict $location] - return [dirfiles_dict_as_lines $contents -stripbase 1] + return [dirfiles_dict_as_lines -stripbase 1 $contents] } #dirfiles dirfiles_dict always deliberately return absolute *unnormalized* path @@ -5187,9 +5189,9 @@ namespace eval punk { set tailglob [file tail $searchspec] } } - puts "-->location:$location" + #puts "-->location:$location" set contents [dirfiles_dict -searchbase $searchbase -tailglob $tailglob $location] - return [dirfiles_dict_as_lines $contents {*}$opts] + return [dirfiles_dict_as_lines -stripbase $opt_stripbase $contents] } #todo - package as punk::navdir @@ -5225,8 +5227,8 @@ namespace eval punk { ] lassign [dict values [get_leading_opts_and_values $defaults $args]] opts searchspecs - puts stderr "searchspecs: $searchspecs [llength $searchspecs]" - puts stdout "arglist: $opts" + #puts stderr "searchspecs: $searchspecs [llength $searchspecs]" + #puts stdout "arglist: $opts" if {[llength $searchspecs] > 1} { #review - spaced paths ? @@ -5284,7 +5286,7 @@ namespace eval punk { } set in_vfs 0 - if {![catch {package require vfs} errM]} { + if {[llength [package provide vfs]]} { foreach mount [vfs::filesystem info] { if {[punk::mix::base::lib::path_a_atorbelow_b $location $mount]} { set in_vfs 1 @@ -5384,48 +5386,85 @@ namespace eval punk { } #todo - color key via repl-telemetry? help command? documentation? or add tag columns as done in namespace listing? - proc dirfiles_dict_as_lines {contents args} { + proc dirfiles_dict_as_lines {args} { + package require overtype + set defaults [list\ -stripbase 0\ ] - set known_opts [dict keys $defaults] - set testedargs [dict create] - foreach {k v} $args { - dict set testedargs [tcl::prefix match -message "dirfiles_dict_as_lines option" $known_opts $k] $v - #if {$k ni $known_opts} { - # error "dirfiles_dict_as_lines unknown argument $k. Known options: $known_opts" - #} - } - set opts [dict merge $defaults $testedargs] + lassign [dict values [get_leading_opts_and_values $defaults $args]] opts list_of_dicts ;#implicit merge of opts over defaults + # -- --- --- --- --- --- --- --- --- --- --- --- set opt_stripbase [dict get $opts -stripbase] # -- --- --- --- --- --- --- --- --- --- --- --- - package require overtype - set dirs [dict get $contents dirs] - set links [dict get $contents links] - set files [dict get $contents files] - set filesizes [dict get $contents filesizes] - set underlayfiles [dict get $contents underlayfiles] - set underlayfilesizes [dict get $contents underlayfilesizes] - set flaggedhidden [dict get $contents flaggedhidden] - set flaggedreadonly [dict get $contents flaggedreadonly] - set flaggedsystem [dict get $contents flaggedsystem] - set nonportable [dict get $contents nonportable] ;# illegal file/folder names from windows perspective - set vfsmounts [dict get $contents vfsmounts] - set searchbase [dict get $contents searchbase] - + #if multiple dicts and -stripbase = 1 - we can only strip the longest common part of the searchbases supplied + set common_base "" + set searchbases [list] + set searchbases_with_len [list] if {$opt_stripbase} { + #todo - case-insensitive comparisons on platforms where that is appropriate (e.g windows) + # - note that the OS could be configured differently in this regard than the default (as could a filesystem such as ZFS), and that for example mounted SMB filesystems are likely to be configured to support the general windows client idea of case-preserving-but-case-insensitive. + # - we may be able to provide a reasonable default for windows vs other - but a proc option is likely needed to allow caller to override the default behaviour on a call by call basis, + # and a config option may be desirable for the user to override the platform default. + # The chosen defaults based on platform may be generally ok - but then not give the desired behaviour when accessing a particular filesystem/mount + if {$::tcl_platform(platform) eq "windows"} { + #case-preserving but case-insensitive matching is the default + foreach d $list_of_dicts { + set str [string tolower [string trim [dict get $d searchbase]]] + lappend searchbases $str + lappend searchbases_with_len [list $str [string length $str]] + } + } else { + #case sensitive + foreach d $list_of_dicts { + set str [string trim [dict get $d searchbase]] + lappend searchbases $str + lappend searchbases_with_len [list $str [string length $str]] + } + } + #if any of the searchbases is empty - there will be no common base - so leave common_base as empty string. + if {"" ni $searchbases} { + set shortest_to_longest [lsort -index 1 -integer $searchbases_with_len] + set prefix_test_list [tcl::prefix all $searchbases [lindex $shortest_to_longest 0 0]] + #if shortest doesn't match all searchbases - we have no common base + if {[llength $prefix_test_list] == [llength $searchbases]} { + set common_base [lindex $shortest_to_longest 0 0]; #we + } + } + } + + foreach fileset [list dirs files links underlayfiles flaggedhidden flaggedreadonly flaggedsystem nonportable vfsmounts] { + set $fileset [list] + } + + #set contents [lindex $list_of_dicts 0] + foreach contents $list_of_dicts { + lappend dirs {*}[dict get $contents dirs] + lappend files {*}[dict get $contents files] + lappend links {*}[dict get $contents links] + lappend filesizes {*}[dict get $contents filesizes] + lappend underlayfiles {*}[dict get $contents underlayfiles] + lappend underlayfilesizes {*}[dict get $contents underlayfilesizes] + lappend flaggedhidden {*}[dict get $contents flaggedhidden] + lappend flaggedreadonly {*}[dict get $contents flaggedreadonly] + lappend flaggedsystem {*}[dict get $contents flaggedsystem] + lappend nonportable {*}[dict get $contents nonportable] ;# illegal file/folder names from windows perspective + lappend vfsmounts {*}[dict get $contents vfsmounts] + } + + if {$opt_stripbase && $common_base ne ""} { set filetails [list] set dirtails [list] - foreach fileset [list dirs files links underlayfiles flaggedhidden flaggedsystem nonportable vfsmounts] { + foreach fileset [list dirs files links underlayfiles flaggedhidden flaggedreadonly flaggedsystem nonportable vfsmounts] { set stripped [list] foreach f [set $fileset] { - lappend stripped [strip_prefix_depth $f $searchbase] + lappend stripped [strip_prefix_depth $f $common_base] } set $fileset $stripped } } + #todo - sort whilst maintaining order for metadata? #col2 with subcolumns @@ -5819,7 +5858,7 @@ namespace eval punk { repl::term::set_console_title [lrange $result 1 end] ;#strip location key } - set out [punk::dirfiles_dict_as_lines $matchinfo -stripbase 1] + set out [punk::dirfiles_dict_as_lines -stripbase 1 $matchinfo] #puts stdout $out #puts stderr [a+ white]$out[a] set chunklist [list] @@ -5856,7 +5895,8 @@ namespace eval punk { if {$::repl::running} { set chunklist [list] } - #only merge results if location matches previous (caller can deliberately intersperse bogus globs to force split if desired) + + #Only merge results if location matches previous (caller can deliberately intersperse bogus globs to force split if desired) #TODO - remove duplicate file or dir items for overlapping patterns in same location!!! (at least for count, filebyte totals if not for display) set last_location "" set this_result [dict create] @@ -5864,7 +5904,7 @@ namespace eval punk { set path [path_to_absolute $searchspec $curdir $::tcl_platform(platform)] set has_tailglob [expr {[regexp {[?*]} [file tail $path]]}] #we have already done a 'cd' if only one unglobbed path was supplied - therefore any remaining non-glob tails must be tested for folderness vs fileness to see what they mean - #this may be slightly surprising if user tries to exactly match both a directory name and a file in that the dir will be listed - but is consistent enough. + #this may be slightly surprising if user tries to exactly match both a directory name and a file both as single objects; because the dir will be listed (auto /* applied to it) - but is consistent enough. #lower level dirfiles or dirfiles_dict can be used to more precisely craft searches. ( d/ will treat dir the same as dir/*) set searchspec_relative [expr {[file pathtype $searchspec] eq "relative"}] @@ -5931,7 +5971,7 @@ namespace eval punk { } dict lappend this_result pattern [dict get $matchinfo opts -glob] if {$::repl::running} { - set out [punk::dirfiles_dict_as_lines $matchinfo -stripbase 1] + set out [punk::dirfiles_dict_as_lines -stripbase 1 $matchinfo] lappend chunklist [list stdout "[a+ white light]$out[a]\n"] } @@ -5981,7 +6021,7 @@ namespace eval punk { } if {$::repl::running} { - set out [punk::dirfiles_dict_as_lines $matchinfo -stripbase 1] + set out [punk::dirfiles_dict_as_lines -stripbase 1 $matchinfo] #return $out\n[pwd] set chunklist [list] lappend chunklist [list stdout "[a+ white light]$out[a]\n"] diff --git a/src/modules/punk/char-999999.0a1.0.tm b/src/modules/punk/char-999999.0a1.0.tm index 61b68b55..9b33206a 100644 --- a/src/modules/punk/char-999999.0a1.0.tm +++ b/src/modules/punk/char-999999.0a1.0.tm @@ -797,6 +797,27 @@ namespace eval punk::char { dict set charsets "Specials" [list ranges [list {start 65520 end 65535}] description "Specials" settype "tcl_supplemental"] + dict set charsets "noncharacters" [list ranges [list\ + {start 64976 end 65007 note "BMP FDD0..FDEF"}\ + {start 65534 end 65535 note "BMP FFFE,FFFF"}\ + {start 131070 end 131071 note "plane1 1FFFE,1FFFF"}\ + {start 196606 end 196607 note "plane2 2FFFE,2FFFF"}\ + {start 262142 end 262143 note "plane3 3FFFE,3FFFF"}\ + {start 327678 end 327679 note "plane4 4FFFE,4FFFF"}\ + {start 393214 end 393215 note "plane5 5FFFE,5FFFF"}\ + {start 458750 end 458751 note "plane6 6FFFE,6FFFF"}\ + {start 524286 end 524287 note "plane7 7FFFE,7FFFF"}\ + {start 589822 end 589823 note "plane8 8FFFE,8FFFF"}\ + {start 655358 end 655359 note "plane9 9FFFE,9FFFF"}\ + {start 720894 end 720895 note "plane10 AFFFE,AFFFF"}\ + {start 786430 end 786431 note "plane11 BFFFE,BFFFF"}\ + {start 851966 end 851967 note "plane12 CFFFE,CFFFF"}\ + {start 917502 end 917503 note "plane13 DFFFE,DFFFF"}\ + {start 983038 end 983039 note "plane14 EFFFE,EFFFF"}\ + {start 1048574 end 1048575 note "plane15 FFFFE,FFFFF"}\ + {start 1114110 end 1114111 note "plane16 10FFFE,10FFFF"}\ + ] description "non-characters" settype "tcl_supplemental"] + #build dicts keyed on short variable charshort proc _build_charshort {} { @@ -1749,7 +1770,12 @@ namespace eval punk::char { set doublewidth_char_count 0 set zerowidth_char_count 0 #split just to get the standalone character widths - and then scan for other combiners (?) - set uc_sequences [regexp -all -inline -indices {[\u0100-\U10FFFF]} $text] + #review + #set can_regex_high_unicode [string match [regexp -all -inline {[\U80-\U0010FFFF]} \U0001F525] \U0001F525] + #tcl pre 2023-11 - braced high unicode regexes don't work + #fixed in bug-4ed788c618 2023-11 + #set uc_sequences [regexp -all -inline -indices {[\u0100-\U10FFFF]} $text] + set uc_sequences [regexp -all -inline -indices "\[\u0100-\U10FFFF\]" $text] foreach uc_range $uc_sequences { set chars [string range $text {*}$uc_range] foreach c $chars { diff --git a/src/modules/punk/console-999999.0a1.0.tm b/src/modules/punk/console-999999.0a1.0.tm index 7249d51f..1cf8bb2c 100644 --- a/src/modules/punk/console-999999.0a1.0.tm +++ b/src/modules/punk/console-999999.0a1.0.tm @@ -26,6 +26,7 @@ if {"windows" eq $::tcl_platform(platform)} { } #see https://learn.microsoft.com/en-us/windows/console/classic-vs-vt +#https://learn.microsoft.com/en-us/windows/console/creating-a-pseudoconsole-session # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punk::console { @@ -132,24 +133,87 @@ namespace eval punk::console { if {$loadstate ni [list loading failed]} { package require twapi ;#should be fast once twapi dll loaded in zzzload thread set ::punk::console::has_twapi 1 + + #todo - move some of these to the punk::console::local sub-namespace - as they use APIs rather than in-band ANSI to do their work. + #enableAnsi seems like it should be directly under punk::console .. but then it seems inconsistent if other local console-mode setting functions aren't. + #Find a compromise to organise things somewhat sensibly.. + proc [namespace parent]::enableAnsi {} { + #output handle modes #Enable virtual terminal processing (sometimes off in older windows terminals) - twapi::SetConsoleMode [twapi::get_console_handle stdout] 5 + #ENABLE_PROCESSED_OUTPUT = 0x0001 + #ENABLE_WRAP_AT_EOL_OUTPUT = 0x0002 + #ENABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004 + #DISABLE_NEWLINE_AUTO_RETURN = 0x0008 + set h_out [twapi::get_console_handle stdout] + set oldmode_out [twapi::GetConsoleMode $h_out] + set newmode_out [expr {$oldmode_out | 5}] ;#5? + + twapi::SetConsoleMode $h_out $newmode_out + + #input handle modes + #ENABLE_PROCESSED_INPUT 0x0001 + #ENABLE_LINE_INPUT 0x0002 + #ENABLE_ECHO_INPUT 0x0004 + #ENABLE_WINDOW_INPUT 0x0008 (default off when a terminal created) + #ENABLE_MOUSE_INPUT 0x0010 + #ENABLE_INSERT_MODE 0X0020 + #ENABLE_QUICK_EDIT_MODE 0x0040 + #ENABLE_VIRTUAL_TERMINAL_INPUT 0x0200 (default off when a terminal created) (512) + set h_in [twapi::get_console_handle stdin] + set oldmode_in [twapi::GetConsoleMode $h_in] + set newmode_in [expr {$oldmode_in | 8}] + + twapi::SetConsoleMode $h_in $newmode_in + + return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] + } + proc [namespace parent]::disableAnsi {} { + set h_out [twapi::get_console_handle stdout] + set oldmode_out [twapi::GetConsoleMode $h_out] + set newmode_out [expr {$oldmode_out & ~5}] + twapi::SetConsoleMode $h_out $newmode_out + + + set h_in [twapi::get_console_handle stdin] + set oldmode_in [twapi::GetConsoleMode $h_in] + set newmode_in [expr {$oldmode_in & ~8}] + twapi::SetConsoleMode $h_in $newmode_in + + + return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] } + + proc [namespace parent]::enableProcessedInput {} { + set h_in [twapi::get_console_handle stdin] + set oldmode_in [twapi::GetConsoleMode $h_in] + set newmode_in [expr {$oldmode_in | 1}] + twapi::SetConsoleMode $h_in $newmode_in + return [list stdin [list from $oldmode_in to $newmode_in]] + } + proc [namespace parent]::disableProcessedInput {} { + set h_in [twapi::get_console_handle stdin] + set oldmode_in [twapi::GetConsoleMode $h_in] + set newmode_in [expr {$oldmode_in & ~1}] + twapi::SetConsoleMode $h_in $newmode_in + return [list stdin [list from $oldmode_in to $newmode_in]] + } + + proc [namespace parent]::enableRaw {{channel stdin}} { #review - change to modify_console_input_mode set console_handle [twapi::GetStdHandle -10] set oldmode [twapi::GetConsoleMode $console_handle] set newmode [expr {$oldmode & ~6}] ;# Turn off the echo and line-editing bits twapi::SetConsoleMode $console_handle $newmode - return $newmode + return [list stdin [list from $oldmode to $newmode]] } proc [namespace parent]::disableRaw {{channel stdin}} { set console_handle [twapi::GetStdHandle -10] set oldmode [twapi::GetConsoleMode $console_handle] set newmode [expr {$oldmode | 6}] ;# Turn on the echo and line-editing bits twapi::SetConsoleMode $console_handle $newmode - return $newmode + return [list stdin [list from $oldmode to $newmode]] } } else { @@ -339,6 +403,7 @@ namespace eval punk::console { set waitvar ::punk::console::chunkdone set existing_handler [fileevent stdin readable] set $waitvar "" + #todo - test and save rawstate so we don't disableRaw if terminal was already raw enableRaw fconfigure stdin -blocking 0 fileevent stdin readable [list ::punk::console::internal::ansi_response_handler stdin $accumulator $waitvar] @@ -378,6 +443,7 @@ namespace eval punk::console { if {!$emit} { puts -nonewline stdout \033\[2K\033\[1G } + flush stdout;#if we don't flush - a subsequent stderr write could move the cursor to a newline and interfere with our 2K1G erasure and cursor repositioning. return [expr {$col2 - $col1}] } @@ -444,7 +510,7 @@ namespace eval punk::console { } } - proc test {} { + proc test_cursor_pos {} { enableRaw puts -nonewline stdout \033\[6n ;flush stdout fconfigure stdin -blocking 0 @@ -518,7 +584,7 @@ namespace eval punk::console { } #this doesn't work - we would need an internal virtual screen structure to pick up cursor attributes from arbitrary locations - #at which point - you are probably better off with curses/ncurses + # ncurses and its ilk may have something like that - but we specifically want to avoid curses libraries proc pick {row col} { lassign [punk::console::get_cursor_pos_list] orig_row orig_col set test "" @@ -783,6 +849,45 @@ namespace eval punk::console { } + proc test {} { + set high_unicode_length [string length \U00010000] + set can_high_unicode 0 + set can_regex_high_unicode 0 + set can_terminal_report_dingbat_width 0 + set can_terminal_report_diacritic_width 0 + if {$high_unicode_length != 1} { + puts stderr "punk::console WARNING: no modern unicode support in this Tcl version. High unicode values not properly supported. (string length \\U00010000 : $high_unicode_length should be 1)" + } else { + set can_high_unicode 1 + set can_regex_high_unicode [string match [regexp -all -inline {[\U80-\U0010FFFF]} \U0001F525] \U0001F525] + if {!$can_regex_high_unicode} { + puts stderr "punk::console warning: TCL version cannot perform braced regex of high unicode" + } + } + set dingbat_heavy_plus_width [punk::console::test_char_width \U2795] ;#review - may be font dependent. We chose a wide dingbat as a glyph that is hopefully commonly renderable - and should display 2 wide. + #This will give a false report that terminal can't report width if the glyph (or replacement glyph) is actually being rendered 1 wide. + #we can't distinguish without user interaction? + if {$dingbat_heavy_plus_width == 2} { + set can_terminal_report_dingbat_width 1 + } else { + puts stderr "punk::console warning: terminal either not displaying wide unicode as wide, or unable to report width properly." + } + set diacritic_width [punk::console::test_char_width a\u0300] + if {$diacritic_width == 1} { + set can_terminal_report_diacritic_width 1 + } else { + puts stderr "punk::console warning: terminal unable to report diacritic width properly." + } + + if {$can_high_unicode && $can_regex_high_unicode && $can_terminal_report_dingbat_width && $can_terminal_report_diacritic_width} { + set result [list result ok] + } else { + set result [list result error] + } + return $result + } + #run the test and allow warnings to be emitted to stderr on package load. User should know the terminal and/or Tcl version are not optimal for unicode character work + #set testresult [test1] } diff --git a/src/modules/punk/du-999999.0a1.0.tm b/src/modules/punk/du-999999.0a1.0.tm index 152305ee..cd6547d5 100644 --- a/src/modules/punk/du-999999.0a1.0.tm +++ b/src/modules/punk/du-999999.0a1.0.tm @@ -224,18 +224,20 @@ namespace eval punk::du { #e.g tcl glob based dirlisting doesn't support gathering file sizes at the same time set in_vfs 0 - 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 {[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 + } } } @@ -779,6 +781,9 @@ namespace eval punk::du { } 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"} { diff --git a/src/modules/punk/mix/templates/module/template_anyname-0.0.2.tm b/src/modules/punk/mix/templates/module/template_anyname-0.0.2.tm new file mode 100644 index 00000000..4bca651b --- /dev/null +++ b/src/modules/punk/mix/templates/module/template_anyname-0.0.2.tm @@ -0,0 +1,51 @@ +# -*- 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 %pkg% 999999.0a1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +apply {code { #auto determine package name and version from name and placement of .tm file + foreach base [tcl::tm::list] { + set nsprefix "";#in case sourced directly and not in any of the .tm paths + if {[string match -nocase ${base}* [info script]]} { + set nsprefix [string trimleft [join [lrange [file split [string range [info script] [string length $base]+1 end]] 0 end-1] ::]:: ::] + break + } + } + set ver [join [lassign [split [file rootname [file tail [info script] ]] -] pkgtail] -] + set pkgns ${nsprefix}${pkgtail} + namespace eval $pkgns [string map [list $pkgns $ver] $code] + package provide $pkgns $ver;# only provide package if code evaluated without error +} ::} { + #-------------------------------------- + variable pkg "" + variable version "" + #-------------------------------------- + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + ## Requirements + ##e.g package require frobz + + + #proc test {args} {puts "[namespace current]::test got args: $args"} + + + + namespace eval [namespace current]::lib { + #proc test {args} {puts "[namespace current]::test got args: $args"} + } + + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + ## Ready +} +return + diff --git a/src/modules/punk/winpath-999999.0a1.0.tm b/src/modules/punk/winpath-999999.0a1.0.tm index 8da9420b..cd4c26e2 100644 --- a/src/modules/punk/winpath-999999.0a1.0.tm +++ b/src/modules/punk/winpath-999999.0a1.0.tm @@ -225,6 +225,22 @@ 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]" + + } } diff --git a/src/modules/punkcheck-0.1.0.tm b/src/modules/punkcheck-0.1.0.tm index 5589fe47..c2c39567 100644 --- a/src/modules/punkcheck-0.1.0.tm +++ b/src/modules/punkcheck-0.1.0.tm @@ -27,7 +27,14 @@ 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 {} { @@ -78,8 +85,132 @@ namespace eval punkcheck { 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 + oo::class create installtrack { + variable o_name + 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 sourceroot targetroot} { + set o_active_event "" + puts "constructor [self]" + set o_name $installername + set o_checkfile [file normalize $punkcheck_file] + #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" + } + if {[file pathtype $sourceroot] ne "absolute"} { + error "[self] constructor error: sourceroot must be absolute path. Received '$sourceroot'" + } + if {[file pathtype $targetroot] ne "absolute"} { + error "[self] constructor error: targetroot must be absolute path. Received '$targetroot'" + } + 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] + + 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] + } else { + set this_installer_record [dict get $resultinfo record] + } + set o_events [oolib::collection new] + set eventlist [punkcheck::dict_getwithdefault $this_installer_record body [list]] + foreach e $eventlist { + $o_events add $e [dict get $e -id] + } + } + destructor { + puts "[self] destructor called" + } + #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] + } + #todo - open file and save only own records + method save_all_records {} { + punkcheck::save_records_to_file $o_record_list $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 {[llength $configdict] %2 != 0} { + error "[self] new_event configdict must have an even number of elements" + } + set eventid [punkcheck::uuid] + 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] + } else { + set this_installer_record [dict get $resultinfo record] + } + + set event_record [punkcheck::recordlist::new_installer_event_record install\ + -id $eventid\ + -source $o_rel_sourceroot\ + -target $o_rel_targetroot\ + -config $configdict\ + ] + + 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] + + if {$existing_header_posn == -1} { + #not found - prepend + set o_record_list [linsert $o_record_list 0 $this_installer_record] + } else { + #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 $eventid + my events add $event_record $eventid + + } + method get_event {} { + return [my events item $o_active_event] + } + method add_target {targetpath} { + + } + 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} { - #set eventid [punkcheck::start_installer_event $punkcheck_file $opt_installer $from $to $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'" @@ -124,7 +255,8 @@ namespace eval punkcheck { } #----------------------------------------------- proc installfile_help {} { - set msg "Call in order:" \n + 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 @@ -199,12 +331,16 @@ namespace eval punkcheck { 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_installing $file_record]} { error "installfile_add_source_and_fetch_metdata error: bad file_record - expected FILEINFO with last body element INSTALLING" } set ts_start [clock microseconds] set last_installrecord [lib::file_record_get_last_installrecord $file_record] + set prev_ftype "" set prev_cksum "" set prev_cksum_opts "" if {[llength $last_installrecord]} { @@ -235,7 +371,8 @@ namespace eval punkcheck { if {$ftype eq "directory"} { set source_cksum_info [punk::mix::base::lib::get_relativecksum_from_base $punkcheck_folder $source_relpath {*}$cksum_opts] } else { - #todo - optionally use mtime instead of cksum (for files only) + #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] } @@ -1194,6 +1331,21 @@ namespace eval punkcheck { dict set installer_record body $body_items return $installer_record } + proc file_record_latest_installrecord {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_latest_installrecord 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 "INSTALLRECORD"} { + return $item + } + } + return [list] + } proc file_record_add_installrecord {file_record install_record} { if {[dict get $file_record tag] ne "FILEINFO"} { error "file_record_add_installrecord bad file_record: tag not FILEINFO" diff --git a/src/modules/punkcheck/cli-999999.0a1.0.tm b/src/modules/punkcheck/cli-999999.0a1.0.tm index 273188c6..5eb8dfa6 100644 --- a/src/modules/punkcheck/cli-999999.0a1.0.tm +++ b/src/modules/punkcheck/cli-999999.0a1.0.tm @@ -55,6 +55,7 @@ namespace eval punkcheck::cli { } set table "" + set files_with_records [list] foreach p $punkcheck_files { set basedir [file dirname $p] set recordlist [punkcheck::load_records_from_file $p] @@ -62,9 +63,9 @@ namespace eval punkcheck::cli { foreach f $files { set relpath [punkcheck::lib::path_relative $basedir $f] if {[dict exists $tgt_dict $relpath]} { - if {[llength $files] == 1} { - set filerec [dict get $tgt_dict $relpath] - set records [punkcheck::dict_getwithdefault $filerec body [list]] + set filerec [dict get $tgt_dict $relpath] + set records [punkcheck::dict_getwithdefault $filerec body [list]] + if {$ftype eq "file"} { if {![llength $records]} { set pcheck "(has file record but no installation entries)" } else { @@ -75,12 +76,55 @@ namespace eval punkcheck::cli { } } } else { - set pcheck "(has record)" + if {![llength $records]} { + set pcheck "(has file record but no installation entries)" + } else { + set display_records [list] + set pcheck \n + set latest_install_record [punkcheck::recordlist::file_record_latest_installrecord $filerec] + lappend display_records $latest_install_record + if {$latest_install_record ne [lindex $records end]} { + lappend display_records [lindex $records end] + } + foreach irec $display_records { + append pcheck "[format %-14s [dict get $irec tag]] [punkcheck::dict_getwithdefault $irec -tsiso "no-timestamp"]" + set bodyrecords [punkcheck::dict_getwithdefault $irec body [list]] + set source_files [list] + set source_files_changed [list] + set source_folders [list] + set source_folders_changed [list] + foreach r $bodyrecords { + if {[dict get $r tag] eq "SOURCE"} { + set path [dict get $r -path] + set changed [dict get $r -changed] + if {[dict get $r -type] eq "file"} { + lappend source_files $path + if {$changed} { + lappend source_files_changed $path + } + } elseif {[dict get $r -type] eq "directory"} { + lappend source_folders $path + if {$changed} { + lappend source_folders_changed $path + } + } + } + } + if {[llength $source_files]} { + append pcheck " source files : [llength $source_files] (changed [llength $source_files_changed])" + } + if {[llength $source_folders]} { + append pcheck " source folders: [llength $source_folders] (changed [llength $source_folders_changed])" + } + append pcheck \n + + #append pcheck [punk::tdl::prettyprint [list $irec] 1] \n + #append pcheck " $irec" \n + } + } } - } else { - set pcheck "" + append table "$f $pcheck" \n } - append table "$f $pcheck" \n } } return $table diff --git a/src/runtime/mapvfs.config b/src/runtime/mapvfs.config new file mode 100644 index 00000000..1769667b --- /dev/null +++ b/src/runtime/mapvfs.config @@ -0,0 +1,4 @@ +#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