Browse Source

pmix repo base fixes, speed up du on windows

master
Julian Noble 1 year ago
parent
commit
4014b0e8a9
  1. 3
      src/modules/punk-0.1.tm
  2. 485
      src/modules/punk/du-999999.0a1.0.tm
  3. 3
      src/modules/punk/du-buildversion.txt
  4. 297
      src/modules/punk/mix-0.2.tm
  5. 1
      src/modules/punk/repl-0.1.tm
  6. 159
      src/modules/punk/repo-999999.0a1.0.tm
  7. 6
      src/modules/punk/winpath-999999.0a1.0.tm

3
src/modules/punk-0.1.tm

@ -72,6 +72,7 @@ namespace eval ::repl {
package require punk::config
package require punk::winpath ;# for windows paths - but has functions that can be called on unix systems
package require punk::repo
package require punk::du
namespace eval punk {
interp alias {} purelist {} lreplace x 0 0 ;#required by pipe system
@ -5980,6 +5981,8 @@ namespace eval punk {
#While in most/normal cases the library will cd back to the remembered working directory after only a brief time - there seem to be many opportunities for issues
#if the repl is used to launch/run a number of things in the one process
proc d/ {args} {
set is_win [expr {"windows" eq $::tcl_platform(platform)}]
set ::punk::last_run_display [list]
if {([llength $args]) && ([lindex $args 0] eq "")} {

485
src/modules/punk/du-999999.0a1.0.tm

@ -0,0 +1,485 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-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 999999.0a1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
##e.g package require frobz
if {"windows" eq $::tcl_platform(platform)} {
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"
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::du {
proc du_lit value {
if {![info exists ::punk::du_literal($value)]} {
set ::punk::du_literal($value) $value
}
return $::punk::du_literal($value)
}
proc _du_new_eachdir {dirtails depth parentfolderidx} {
set newlist {}
upvar folders folders
set parentpath [lindex $folders $parentfolderidx]
set newindex [llength $folders]
foreach dt $dirtails {
lappend folders $parentpath/$dt
lappend newlist [::list $depth $parentfolderidx $newindex $dt [expr {0}]]
incr newindex
}
return $newlist
}
proc du_listing {folderpath} {
#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 - 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} -tail * .*]
#set hdirs {}
set dirs [glob -nocomplain -dir $folderpath -types d -tail * .*]
#set hlinks [glob -nocomplain -dir [lindex $folders $folderidx] -types {hidden l} -tail * .*]
set hlinks {}
set links [glob -nocomplain -dir $folderpath -types l -tail * .*] ;#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} -tail * .*]
#set hfiles {}
set files [glob -nocomplain -dir $folderpath -types f -tail * .*]
#set files {}
#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 {. ..}]]
set files [struct::set difference [concat $hfiles $files[unset files]] $links]
set filesizes [list]; #not available in listing-call - as opposed to twapi which can do it as it goes
return [list $dirs $files $filesizes]
}
# get listing without using unix-tools (may not be installed on the windows system)
proc du_listing_twapi {folderpath} {
package require punk::winpath
set dirs [list]
set files [list]
set filesizes [list]
try {
if {[string length [file normalize $folderpath]] >= 250} {
set folderpath_shortname [punk::winpath::pwdshortname $folderpath]
set iterator [twapi::find_file_open $folderpath_shortname/* -detail basic]
} else {
set iterator [twapi::find_file_open $folderpath/* -detail basic] ;# -detail full only adds data to the altname field
}
} on error args {
if {[string match "*denied*" $args]} {
#output similar format as unixy du
puts stderr "[file dirname $folderpath] '[file tail $folderpath]':$args"
return [list {} {} {}]
}
#possibly an illegal windows filename - easily happens on a machine with WSL or with drive mapped to unix share
set errmsg "error reading folder: $folderpath (len:[string length [file normalize $folderpath]])\n"
append errmsg "error: $args" \n
append errmsg "errorcode: $::errorCode" \n
append errmsg {retrying with with windows altname}
puts stderr $errmsg
try {
#go to parent and re-fetch this folder with altnames
#use normalize to get full path - in case we are currently at "."
set parent [file dirname [file normalize $folderpath]]
set iterator [twapi::find_file_open $parent/* -detail full] ;# -detail full because we need altname!
while {[twapi::find_file_next $iterator iteminfo]} {
set nm [dict get $iteminfo name]
if {$nm eq [file tail $folderpath]} {
break
}
}
if {$nm ne [file tail $folderpath]} {
error "failed to re-fetch current directory info with altpath info"
}
set altname [dict get $iteminfo altname]
puts stderr "using altname $parent/$altname"
set iterator [twapi::find_file_open $parent/$altname/* -detail basic]
} on error args {
set errmsg "error reading folder: $parent or $folderpath\n"
append errmsg "error: $args"
append errmsg "aborting.."
error $errmsg
}
}
while {[twapi::find_file_next $iterator iteminfo]} {
set nm [dict get $iteminfo name]
if {$nm in {. ..}} {
continue
}
set attrinfo [twapi::decode_file_attributes [dict get $iteminfo attrs]]
if {"reparse_point" in $attrinfo} {
#we will treat as a zero sized file.. 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 <SYMLINKD> 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.
#This .lnk seems to be an ordinary file and we can treat as such here.
lappend files $nm
lappend filesizes 0
} elseif {"directory" in $attrinfo} {
lappend dirs $nm
} else {
lappend files $nm
lappend filesizes [dict get $iteminfo size]
}
}
return [list $dirs $files $filesizes]
}
#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 though
proc du { args } {
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 singletons (or longopts --something=somethingelse) or sometimes pairopts
# process any pairopts first
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"
}
}
}
#----
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 result [list]
set dir_depths_remaining [list]
#if {[file normalize [file dirname $dir]] eq [file normalize $dir]} {
# error "du at root of filesystem not yet implemented.. sorry"
#
#}
set is_windows [expr {$::tcl_platform(platform) eq "windows"}]
set has_twapi 0 ;#default assumption
if {$is_windows} {
if {![catch {
package require twapi
}
]} {
set has_twapi 1
}
}
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}] [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}] [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
#}
if {$is_windows && $has_twapi} {
lassign [du_listing_twapi $folderpath] dirs files filesizes; #twapi supports gathering file sizes during directory contents traversal
} else {
lassign [du_listing $folderpath] dirs files filesizes ;#filesizes is empty list if listing mechanism doesn't support it (as Tcl glob doesn't)
}
incr leveldirs [llength $dirs]
incr levelfiles [llength $files]
#lappend dir_depths_remaining {*}[lmap d $dirs {::list $nextdepth [du_lit $cont/$itm] $d $zero}]
#folderidx is parent index for new dirs
lappend dir_depths_remaining {*}[_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 "$folderpath/$filename"]
}
} else {
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
}
package require natsort
#interp alias {} du {} .=args>* punk::du |> .=>1 natsort::sort -cols 1 |> list_as_lines <args|
#use natsort -debug 2 to see index output
#this works better for display of directory/file names with spaces (doesn't show curly braces)
interp alias {} du2 {} .=args>* punk::du::du |> .=>1 natsort::sort -cols 1 -outputformat words |> list_as_lines <args|
#experiment with csv as easy way to get column like format..
#The /r is somewhat cheating however.. as it messes up redirected output .. e.g if redirected to text file
interp alias {} du {} .=args>* punk::du::du |> .=>1 natsort::sort -cols 1 -outputformat csv -outputformatoptions {\r\t\t\t} |> list_as_lines <args|
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::du [namespace eval punk::du {
variable version
set version 999999.0a1.0
}]
return

3
src/modules/punk/du-buildversion.txt

@ -0,0 +1,3 @@
0.1.0
#First line must be a semantic version number
#all other lines are ignored.

297
src/modules/punk/mix-0.2.tm

@ -16,6 +16,9 @@ namespace eval punk::mix::cli {
return $basehelp
}
proc status {{project ""}} {
set result ""
if {[string length $project]} {
@ -26,12 +29,16 @@ namespace eval punk::mix::cli {
if {[punk::repo::is_fossil $active_dir]} {
set fosroot [punk::repo::find_fossil $active_dir]
if {[punk::repo::is_candidate_root $active_dir] && ([string tolower $fosroot] ne [string tolower $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 "** current folder has /src & /modules dirs - but isn't the project root" \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 "** project root : $fosroot ([punk::repo::path_relative $active_dir $fosroot])" \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
}
@ -49,6 +56,19 @@ namespace eval punk::mix::cli {
} 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
@ -56,7 +76,9 @@ namespace eval punk::mix::cli {
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. Expecting folder containing src,src/lib,src/modules,lib,modules" \n
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]
}
}
}
@ -124,10 +146,10 @@ namespace eval punk::mix::cli {
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 [gets stdin]
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 to proceed) use -confirm 0 to avoid prompts."
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
}
}
@ -153,10 +175,10 @@ namespace eval punk::mix::cli {
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 [gets stdin]
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 to proceed) use -confirm 0 to avoid prompts."
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
}
}
@ -168,10 +190,10 @@ namespace eval punk::mix::cli {
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 [gets stdin]
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 to proceed) use -confirm 0 to avoid prompts."
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
@ -373,10 +395,10 @@ namespace eval punk::mix::cli {
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"
set answer [gets stdin]
set answer [string tolower [gets stdin]]
fconfigure stdin -blocking [dict get $stdin_state -blocking]
if {[string tolower $answer] ne "Y"} {
puts stderr "mix new aborting due to user response '$answer' (required Y or y to proceed) use -askme 0 to avoid prompts."
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
}
}
@ -527,10 +549,10 @@ namespace eval punk::mix::cli {
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 [gets stdin]
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 to proceed) use -confirm 0 to avoid prompts."
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
}
}
@ -686,7 +708,6 @@ namespace eval punk::mix::cli {
}
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]]
@ -736,242 +757,6 @@ namespace eval punk::mix::cli {
}
#todo - package up
#todo - use winpath module's illegal name fix on windows
proc du_lit value {
if {![info exists ::punk::du_literal($value)]} {
set ::punk::du_literal($value) $value
}
return $::punk::du_literal($value)
}
proc _du_new_eachdir {dirtails depth parentfolderidx} {
set newlist {}
upvar folders folders
set parentpath [lindex $folders $parentfolderidx]
set newindex [llength $folders]
foreach dt $dirtails {
lappend folders $parentpath/$dt
lappend newlist [::list $depth $parentfolderidx $newindex $dt [expr {0}]]
incr newindex
}
return $newlist
}
proc du_listing {folderpath} {
#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 - 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} -tail * .*]
#set hdirs {}
set dirs [glob -nocomplain -dir $folderpath -types d -tail * .*]
#set hlinks [glob -nocomplain -dir [lindex $folders $folderidx] -types {hidden l} -tail * .*]
set hlinks {}
set links [glob -nocomplain -dir $folderpath -types l -tail * .*] ;#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} -tail * .*]
#set hfiles {}
set files [glob -nocomplain -dir $folderpath -types f -tail * .*]
#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 {. ..}]]
set files [struct::set difference [concat $hfiles $files[unset files]] $links]
return [list $dirs $files]
}
proc du { args } {
package require struct::set
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 result [list]
set dir_depths_remaining [list]
#if {[file normalize [file dirname $dir]] eq [file normalize $dir]} {
# error "du at root of filesystem not yet implemented.. sorry"
#
#}
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}] [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}] [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 [list]
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]
lassign [du_listing $folderpath] dirs files
#lappend dir_depths_remaining {*}[lmap d $dirs {::list $nextdepth [du_lit $cont/$itm] $d $zero}]
#folderidx is parent index for new dirs
lappend dir_depths_remaining {*}[_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}]
foreach filename $files {
incr bytecount [file size "$folderpath/$filename"]
}
#we can safely assume initial count was zero
lset dir_depths_remaining $i $i_size $bytecount
#incr diridx
}
#puts stdout "level: $level dirs: $leveldirs"
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 - the real time is for large trees in the main loop above
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]
#
#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 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
}
package require natsort
#interp alias {} du {} .=args>* punk::mix::cli::lib::du |> .=>1 natsort::sort -cols 1 |> list_as_lines <args|
#use natsort -debug 2 to see index output
#this works better for display of directory/file names with spaces (doesn't show curly braces)
interp alias {} du {} .=args>* punk::mix::cli::lib::du |> .=>1 natsort::sort -cols 1 -outputformat words |> list_as_lines <args|
#experiment with csv as easy way to get column like format..
#The /r is somewhat cheating however.. as it messes up redirected output .. e.g if redirected to text file
interp alias {} du2 {} .=args>* punk::mix::cli::lib::du |> .=>1 natsort::sort -cols 1 -outputformat csv -outputformatoptions {\r\t\t\t} |> list_as_lines <args|
#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??)

1
src/modules/punk/repl-0.1.tm

@ -99,6 +99,7 @@ namespace eval punkrepl {
}
namespace eval repl {
#since we are targeting Tcl 8.6+ - we should be using 'interp bgerror .'
#todo - make optional/configurable?
proc bgerror2 {args} {
puts stderr "===================="

159
src/modules/punk/repo-999999.0a1.0.tm

@ -119,7 +119,7 @@ namespace eval punk::repo {
if {$path eq {}} { set path [pwd] }
expr {[is_fossil_root $path] || [is_git_root $path]}
}
#require a minimum of /src and /modules - and that it's otherwise sensible
#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] }
@ -140,16 +140,37 @@ namespace eval punk::repo {
#review - adjust to allow symlinks to folders?
foreach required {
src
src/lib
src/modules
lib
modules
} {
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/<something>.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?
@ -165,6 +186,134 @@ namespace eval punk::repo {
return 1
}
proc find_roots_and_warnings_dict {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
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 fosroot [punk::repo::find_fossil $start_dir]
dict set root_dict fossil $fosroot
set gitroot [punk::repo::find_git $start_dir]
dict set root_dict git $gitroot
set candroot [punk::repo::find_candidate $start_dir]
dict set root_dict candidate $candroot
if {[string length $fosroot]} {
if {([string length $candroot]) && ([string tolower $fosroot] ne [string tolower $candroot])} {
#todo - only warn if this candidate is *within* the found repo root?
append msg "**" \n
append msg "** found folder with /src at or above starting folder - that isn't the fossil root" \n
append msg "** starting folder : $start_dir" \n
append msg "** unexpected : $candroot" \n
append msg "** fossil root : $fosroot ([punk::repo::path_relative $start_dir $fosroot])" \n
append msg "** reporting based on the fossil root found."
append msg "**" \n
}
} else {
if {[string length $gitroot]} {
if {([string length $candroot]) && ([string tolower $gitroot] ne [string tolower $candroot])} {
append msg "**" \n
append msg "** found folder with /src at or above current folder - that isn't the git root" \n
append msg "** starting folder : $start_dir" \n
append msg "** unexpected : $candroot ([punk::repo::path_relative $start_dir $candroot])" \n
append msg "** git root : $gitroot ([punk::repo::path_relative $start_dir $gitroot])" \n
append msg "** reporting based on the git root found."
append msg "**" \n
}
} else {
}
}
if {(![string length [dict get $root_dict fossil]])} {
append msg "Not a punk fossil project" \n
}
#don't warn if not git - unless also not fossil
if {(![string length [dict get $root_dict fossil]]) && (![string length [dict get $root_dict git]])} {
append msg "No repository located at or above starting folder $start_dir" \n
if {![string length [dict get $root_dict candidate]]} {
append msg "No candidate project root found. "
append msg "Searched upwards from '$start_dir' expecting a folder with the following requirements: " \n
append msg [punk::repo::is_candidate_root_requirements_msg]
} else {
append msg "Candidate project root found at : $candidate" \n
append msg " - consider putting this folder under fossil control (and/or git)" \n
}
}
set pathinfo [list];#exclude not found
foreach repotype [list fossil git candidate] {
set path [dict get $root_dict $repotype]
if {[string length $path]} {
set plen [llength [file split $path]]
lappend pathinfo [list $repotype $path $plen]
}
}
#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 -index 2 $pathinfo]
if {![llength $longest_first]} {
#no repos or candidate - we have already created msg above
} else {
dict set root_dict closest [lindex $longest_first 0 1] ;#the *path* of the closest to start_dir - now we need to find all the types of this len
#see if others same len
set longestlen [lindex $longest_first 0 2]
set equal_longest [lsearch -all -inline -index 2 $longest_first $longestlen]
set ctypes [list]
foreach pinfo $equal_longest {
lappend ctypes [lindex $pinfo 0]
}
dict set root_dict closest_types $ctypes
}
if {[string length [set fosroot [dict get $root_dict fossil]]] && [string length [set gitroot [dict get $root_dict git]]]} {
}
dict set root_dict warnings $msg
#some quick sanity checks..
set ctypes [dict get $root_dict closest_types]
if {"project" in $ctypes} {
if {"candidate" ni $ctypes} {
set errmsg "find_roots_and_warnings_dict logic error: have project but not also classified as candidate (coding error in punk::repo) - inform developer\n"
append errmsg " warnings gathered before error:\n $msg"
error $errmsg
}
if {("git" ni $ctypes) && ("fossil" ni $ctypes)} {
set errmsg "find_roots_and_warnings_dict logic error: have project but not also at least one of 'git', 'fossil' (coding error in punk::repo) - inform developer\n"
append errmsg " warnings gathered before error:\n $msg"
error $errmsg
}
}
set ctype_paths [list]
foreach ctype [dict get $root_dict closest_types] {
lappend ctype_paths [lindex [dict get $root_dict $ctype] 1] ;# type, path, len
}
set unique [lsort -unique $ctype_paths]
if {[llength $unique] > 1} {
# this may be a filesystem path representation issue? case? normalisation?
set errmsg "find_roots_and_warnings_dict logic error: different paths for closest folders found (error in punk::repo) - inform developer\n"
append errmsg " warnings gathered before error:\n $msg"
error $errmsg
}
return $root_dict
}
proc git_revision {{path {}}} {
if {$path eq {}} { set path [pwd] }
# ::kettle::path::revision.git

6
src/modules/punk/winpath-999999.0a1.0.tm

@ -156,6 +156,12 @@ namespace eval punk::winpath {
}
}
proc pwdshortname {{path {}}} {
if {![string length $path]} {
set path [pwd]
}
return [dict get [file attributes [file normalize $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} {

Loading…
Cancel
Save