You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1487 lines
70 KiB
1487 lines
70 KiB
# -*- tcl -*- |
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
|
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
|
# |
|
# 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) 2024 |
|
# |
|
# @@ Meta Begin |
|
# Application punk::nav::fs 999999.0a1.0 |
|
# Meta platform tcl |
|
# Meta license <unspecified> |
|
# @@ Meta End |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# doctools header |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
#*** !doctools |
|
#[manpage_begin punkshell_module_punk::nav::fs 0 999999.0a1.0] |
|
#[copyright "2024"] |
|
#[titledesc {punk::nav::fs console filesystem navigation}] [comment {-- Name section and table of contents description --}] |
|
#[moddesc {fs nav}] [comment {-- Description at end of page heading --}] |
|
#[require punk::nav::fs] |
|
#[keywords module filesystem terminal] |
|
#[description] |
|
#[para] - |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[section Overview] |
|
#[para] overview of punk::nav::fs |
|
#[subsection Concepts] |
|
#[para] - |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Requirements |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[subsection dependencies] |
|
#[para] packages used by punk::nav::fs |
|
#[list_begin itemized] |
|
|
|
package require Tcl 8.6- |
|
package require punk::lib |
|
package require punk::args |
|
package require punk::ansi |
|
package require punk::winpath |
|
package require punk::du |
|
package require commandstack |
|
#*** !doctools |
|
#[item] [package {Tcl 8.6}] |
|
#[item] [package {punk::lib}] |
|
#[item] [package {punk::args}] |
|
#[item] [package {punk::winpath}] |
|
#[item] [package {punk::du}] |
|
#[item] [package {punk::commandstack}] |
|
|
|
if {"windows" eq $::tcl_platform(platform)} { |
|
catch {package require punk::unixywindows} |
|
} |
|
# #package require frobz |
|
# #*** !doctools |
|
# #[item] [package {frobz}] |
|
|
|
#*** !doctools |
|
#[list_end] |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[section API] |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# oo::class namespace |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
#tcl::namespace::eval punk::nav::fs::class { |
|
#*** !doctools |
|
#[subsection {Namespace punk::nav::fs::class}] |
|
#[para] class definitions |
|
#if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { |
|
#*** !doctools |
|
#[list_begin enumerated] |
|
|
|
# oo::class create interface_sample1 { |
|
# #*** !doctools |
|
# #[enum] CLASS [class interface_sample1] |
|
# #[list_begin definitions] |
|
|
|
# method test {arg1} { |
|
# #*** !doctools |
|
# #[call class::interface_sample1 [method test] [arg arg1]] |
|
# #[para] test method |
|
# puts "test: $arg1" |
|
# } |
|
|
|
# #*** !doctools |
|
# #[list_end] [comment {-- end definitions interface_sample1}] |
|
# } |
|
|
|
#*** !doctools |
|
#[list_end] [comment {--- end class enumeration ---}] |
|
#} |
|
#} |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# Base namespace |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
tcl::namespace::eval punk::nav::fs { |
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
|
|
|
#Both tcl's notion of pwd and VIRTUAL_CWD can be out of sync with the process CWD. This happens when in a VFS. |
|
#We can also have VIRTUAL_CWD navigate to spaces that Tcl's cd can't - review |
|
|
|
variable VIRTUAL_CWD ;#cwd that tracks pwd except when in zipfs locations that are not at or below a mountpoint |
|
if {![interp issafe]} { |
|
set VIRTUAL_CWD [pwd] |
|
} else { |
|
set VIRTUAL_CWD "" |
|
} |
|
proc vwd {} { |
|
variable VIRTUAL_CWD |
|
set cwd [pwd] |
|
if {$cwd ne $VIRTUAL_CWD} { |
|
puts stderr "pwd: $cwd" |
|
} |
|
return $::punk::nav::fs::VIRTUAL_CWD |
|
} |
|
|
|
#TODO - maintain per 'volume/server' CWD |
|
#e.g cd and ./ to: |
|
# d: |
|
# //zipfs: |
|
# //server |
|
# https://example.com |
|
# should return to the last CWD for that volume/server |
|
|
|
#VIRTUAL_CWD follows pwd when changed via cd |
|
set stackrecord [commandstack::rename_command -renamer punk::nav::fs cd {args} { |
|
if {![catch { |
|
$COMMANDSTACKNEXT {*}$args |
|
} errM]} { |
|
set ::punk::nav::fs::VIRTUAL_CWD [pwd] |
|
} else { |
|
error $errM |
|
} |
|
}] |
|
|
|
#*** !doctools |
|
#[subsection {Namespace punk::nav::fs}] |
|
#[para] Core API functions for punk::nav::fs |
|
#[list_begin definitions] |
|
|
|
|
|
#NOTE - as we expect to run other apps (e.g Tk) in the same process, but possibly different threads - we should be careful about use of cd which is per-process not per-thread. |
|
#As this function recurses and calls cd multiple times - it's not thread-safe. |
|
#Another thread could theoretically cd whilst this is running. |
|
#Most likely this will then just error-out - but there is a possibility we could end up in the wrong directory, or cause the same problems in the other thread. |
|
#REVIEW - consider looking at current directory only at the beginning and do a single cd to an absolute path. |
|
#currently this allows ./ subdir subdir2 nonexistant and we cd to subdir/subdir2 even though an error is produced at the end. |
|
#This offers a convenience for repl useage at the slight cost of more potential cross-thread cd interference |
|
#- although presumably most library code shouldn't be changing CWD anyway. |
|
#Ideally the user/repl should be in control of the processes working directory and we shouldn't have to worry too much here. |
|
#Notably for example tcltest-2.5.5 at least uses cd - so this is something that may be best run in a separate process (for each test suite?) |
|
#This seems unfortunate - as a multithreaded set of test runs might otherwise have made some sense.. but perhaps for tests more serious isolation is a good idea. |
|
#It also seems common to cd when loading certain packages e.g tls from starkit. |
|
#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} { |
|
variable VIRTUAL_CWD |
|
|
|
set is_win [expr {"windows" eq $::tcl_platform(platform)}] |
|
|
|
set repl_runid 0 |
|
if {[info commands ::punk::get_repl_runid] ne ""} { |
|
set repl_runid [punk::get_repl_runid] |
|
} |
|
#set ::punk::last_run_display [list] |
|
|
|
if {([llength $args]) && ([lindex $args 0] eq "")} { |
|
set args [lrange $args 1 end] |
|
} |
|
|
|
|
|
if {![llength $args]} { |
|
#ls is too slow even over a fairly low-latency network |
|
#set out [runout -n ls -aFC] |
|
if {[string match //zipfs:/* $VIRTUAL_CWD]} { |
|
if {[Zipfs_path_within_zipfs_mounts $VIRTUAL_CWD]} { |
|
if {[pwd] ne $VIRTUAL_CWD} { |
|
commandstack::basecall cd $VIRTUAL_CWD |
|
} |
|
} |
|
set matchinfo [dirfiles_dict -searchbase $VIRTUAL_CWD -with_times {f d l} -with_sizes {f d l}] |
|
} else { |
|
if {[pwd] ne $VIRTUAL_CWD} { |
|
commandstack::basecall cd $VIRTUAL_CWD |
|
} |
|
set matchinfo [dirfiles_dict -searchbase [pwd] -with_times {f d l} -with_sizes {f d l}] |
|
} |
|
set dircount [llength [dict get $matchinfo dirs]] |
|
set filecount [llength [dict get $matchinfo files]] |
|
set symlinkcount [llength [dict get $matchinfo links]] ;#doesn't include windows shelllinks (.lnk) |
|
#set location [file normalize [dict get $matchinfo location]] |
|
set location [dict get $matchinfo location] |
|
|
|
|
|
#result for glob is count of matches - use dirfiles etc for script access to results |
|
set result [list location $location dircount $dircount filecount $filecount symlinks $symlinkcount] |
|
set filesizes [dict get $matchinfo filesizes] |
|
if {[llength $filesizes]} { |
|
set filesizes [lsearch -all -inline -not $filesizes na] |
|
set filebytes [tcl::mathop::+ {*}$filesizes] |
|
lappend result filebytes [punk::lib::format_number $filebytes] |
|
} |
|
if {[punk::nav::fs::system::codethread_is_running]} { |
|
if {[llength [info commands ::punk::console::titleset]]} { |
|
#if ansi is off - punk::console::titleset will try 'local' api method - which can fail |
|
catch {::punk::console::titleset [lrange $result 1 end]} |
|
} |
|
} |
|
if {[string match //zipfs:/* $location]} { |
|
set stripbase 0 |
|
} else { |
|
set stripbase 1 |
|
} |
|
set out [dirfiles_dict_as_lines -stripbase $stripbase $matchinfo] |
|
set chunklist [list] |
|
lappend chunklist [list stdout "[punk::ansi::a+ brightwhite]$out[punk::ansi::a]\n"] |
|
if {[file normalize $VIRTUAL_CWD] ne [pwd]} { |
|
lappend chunklist [list stderr "[punk::ansi::a+ red]PWD:[pwd] VIRTUAL_CWD:$VIRTUAL_CWD[punk::ansi::a]"] |
|
} |
|
lappend chunklist [list result $result] |
|
if {$repl_runid != 0} { |
|
if {![tsv::llength repl runchunks-$repl_runid]} { |
|
#set ::punk::last_run_display $chunklist |
|
tsv::lappend repl runchunks-$repl_runid {*}$chunklist |
|
} |
|
} else { |
|
punk::nav::fs::system::emit_chunklist $chunklist |
|
} |
|
#puts stdout "-->[ansistring VIEW $result]" |
|
return $result |
|
} else { |
|
set atail [lassign $args a1] |
|
if {[llength $args] == 1} { |
|
set a1 [lindex $args 0] |
|
switch -exact -- $a1 { |
|
. - ./ { |
|
tailcall punk::nav::fs::d/ |
|
} |
|
.. - ../ { |
|
if {$VIRTUAL_CWD eq "//zipfs:/" && ![string match //zipfs:/* [pwd]]} { |
|
#exit back to last nonzipfs path that was in use |
|
set VIRTUAL_CWD [pwd] |
|
tailcall punk::nav::fs::d/ |
|
} |
|
|
|
#we need to use normjoin to allow navigation to //server instead of just to //server/share (//server browsing unimplemented - review) |
|
# [file join //server ..] would become /server/.. - use normjoin to get //server |
|
# file dirname //server/share would stay as //server/share |
|
#set up1 [file dirname $VIRTUAL_CWD] |
|
set up1 [punk::path::normjoin $VIRTUAL_CWD ..] |
|
if {[string match //zipfs:/* $up1]} { |
|
if {[Zipfs_path_within_zipfs_mounts $up1]} { |
|
cd $up1 |
|
set VIRTUAL_CWD $up1 |
|
} else { |
|
set VIRTUAL_CWD $up1 |
|
} |
|
} else { |
|
cd $up1 |
|
#set VIRTUAL_CWD [file normalize $a1] |
|
} |
|
tailcall punk::nav::fs::d/ |
|
} |
|
} |
|
|
|
if {[file pathtype $a1] ne "relative"} { |
|
if { ![string match //zipfs:/* $a1]} { |
|
if {[file type $a1] eq "directory"} { |
|
cd $a1 |
|
#set VIRTUAL_CWD $a1 |
|
tailcall punk::nav::fs::d/ |
|
} |
|
} |
|
} |
|
|
|
|
|
if {![regexp {[*?]} $a1] && ![string match //zipfs:/* $a1] && ![string match "//zipfs:/*" $VIRTUAL_CWD]} { |
|
if {[file type $a1] eq "directory"} { |
|
cd $a1 |
|
#set VIRTUAL_CWD [file normalize $a1] |
|
tailcall punk::nav::fs::d/ |
|
} |
|
} |
|
|
|
if {![regexp {[*?]} $a1]} { |
|
#NON-Glob target |
|
#review |
|
if {[string match //zipfs:/* $a1]} { |
|
if {[Zipfs_path_within_zipfs_mounts $a1]} { |
|
commandstack::basecall cd $a1 |
|
} |
|
set VIRTUAL_CWD $a1 |
|
set curdir $a1 |
|
} else { |
|
set target [punk::path::normjoin $VIRTUAL_CWD $a1] |
|
if {[string match //zipfs:/* $VIRTUAL_CWD]} { |
|
if {[Zipfs_path_within_zipfs_mounts $target]} { |
|
commandstack::basecall cd $target |
|
} |
|
} |
|
if {[file type $target] eq "directory"} { |
|
set VIRTUAL_CWD $target |
|
} |
|
} |
|
tailcall punk::nav::fs::d/ |
|
} |
|
set curdir $VIRTUAL_CWD |
|
} else { |
|
set curdir [pwd] |
|
} |
|
|
|
|
|
#globchar somewhere in path - treated as literals except in final segment (for now. todo - make more like ns/ which accepts full path globbing with double ** etc.) |
|
|
|
set searchspec [lindex $args 0] |
|
|
|
set result "" |
|
set chunklist [list] |
|
|
|
#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] |
|
foreach searchspec $args { |
|
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 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"}] |
|
if {$has_tailglob} { |
|
set location [file dirname $path] |
|
set glob [file tail $path] |
|
if {$searchspec_relative} { |
|
set searchbase [pwd] |
|
} else { |
|
set searchbase [file dirname $searchspec] |
|
} |
|
} else { |
|
if {[string match //zipfs:/* $path]} { |
|
set location $path |
|
set glob * |
|
set searchbase $path |
|
} elseif {[file isdirectory $path]} { |
|
set location $path |
|
set glob * |
|
if {$searchspec_relative} { |
|
set searchbase [pwd] |
|
} else { |
|
set searchbase $path |
|
} |
|
} else { |
|
set location [file dirname $path] |
|
set glob [file tail $path] ;#search for exact match file |
|
if {$searchspec_relative} { |
|
set searchbase [pwd] |
|
} else { |
|
set searchbase [file dirname $path] |
|
} |
|
} |
|
} |
|
set matchinfo [dirfiles_dict -searchbase $searchbase -tailglob $glob -with_sizes {f d l} -with_times {f d l} $location] |
|
#puts stderr "=--->$matchinfo" |
|
|
|
|
|
set location [file normalize [dict get $matchinfo location]] |
|
if {[string match //xzipfs:/* $location] || $location ne $last_location} { |
|
#REVIEW - zipfs test disabled with leading x |
|
#emit previous result |
|
if {[dict size $this_result]} { |
|
dict set this_result filebytes [punk::lib::format_number [dict get $this_result filebytes]] |
|
lappend chunklist [list result $this_result] |
|
if {$result ne ""} { |
|
append result \n |
|
} |
|
append result $this_result |
|
} |
|
set this_result [dict create] |
|
set dircount 0 |
|
set filecount 0 |
|
} |
|
incr dircount [llength [dict get $matchinfo dirs]] |
|
incr filecount [llength [dict get $matchinfo files]] |
|
|
|
#result for glob is count of matches - use dirfiles etc for script access to results |
|
dict set this_result location $location |
|
dict set this_result dircount $dircount |
|
dict set this_result filecount $filecount |
|
|
|
set filesizes [dict get $matchinfo filesizes] |
|
if {[llength $filesizes]} { |
|
set filesizes [lsearch -all -inline -not $filesizes na] |
|
set filebytes [tcl::mathop::+ {*}$filesizes] |
|
dict incr this_result filebytes $filebytes |
|
} else { |
|
dict incr this_result filebytes 0 ;#ensure key exists! |
|
} |
|
dict lappend this_result pattern [dict get $matchinfo opts -glob] |
|
|
|
if {[string match //zipfs:/* $location]} { |
|
set stripbase 0 |
|
} else { |
|
set stripbase 1 |
|
} |
|
set out [dirfiles_dict_as_lines -stripbase $stripbase $matchinfo] |
|
|
|
lappend chunklist [list stdout "[punk::ansi::a+ brightwhite]$out[punk::ansi::a]\n"] |
|
|
|
set last_location $location |
|
} |
|
#process final result |
|
if {[dict size $this_result]} { |
|
dict set this_result filebytes [punk::lib::format_number [dict get $this_result filebytes]] |
|
lappend chunklist [list result $this_result] |
|
if {$result ne ""} { |
|
append result \n |
|
} |
|
append result $this_result |
|
} |
|
if {[file normalize $VIRTUAL_CWD] ne [pwd]} { |
|
lappend chunklist [list stderr "[punk::ansi::a+ red]PWD:[pwd] VIRTUAL_CWD:$VIRTUAL_CWD[punk::ansi::a]"] |
|
} |
|
|
|
|
|
if {[punk::nav::fs::system::codethread_is_running]} { |
|
if {![tsv::llength repl runchunks-$repl_runid]} { |
|
#set ::punk::last_run_display $chunklist |
|
tsv::lappend repl runchunks-$repl_runid {*}$chunklist |
|
} |
|
} |
|
if {$repl_runid == 0} { |
|
punk::nav::fs::system::emit_chunklist $chunklist |
|
} |
|
return $result |
|
} |
|
} |
|
|
|
proc dd/ {args} { |
|
#set ::punk::last_run_display [list] |
|
set repl_runid 0 |
|
if {[info commands ::punk::get_repl_runid] ne ""} { |
|
set repl_runid [punk::get_repl_runid] |
|
} |
|
if {![llength $args]} { |
|
set path .. |
|
} else { |
|
set path ../[file join {*}$args] |
|
} |
|
set normpath [file normalize $path] |
|
cd $normpath |
|
set matchinfo [dirfiles_dict -searchbase $normpath -with_sizes {f d l} -with_times {f d l} $normpath] |
|
set dircount [llength [dict get $matchinfo dirs]] |
|
set filecount [llength [dict get $matchinfo files]] |
|
set location [file normalize [dict get $matchinfo location]] |
|
#result for glob is count of matches - use dirfiles etc for script access to results |
|
set result [list location $location dircount $dircount filecount $filecount] |
|
set filesizes [dict get $matchinfo filesizes] |
|
if {[llength $filesizes]} { |
|
set filesizes [lsearch -all -inline -not $filesizes na] |
|
set filebytes [tcl::mathop::+ {*}$filesizes] |
|
lappend result filebytes [punk::lib::format_number $filebytes] |
|
} |
|
|
|
set out [dirfiles_dict_as_lines -stripbase 1 $matchinfo] |
|
#return $out\n[pwd] |
|
set chunklist [list] |
|
lappend chunklist [list stdout "[punk::ansi::a+ brightwhite]$out[punk::ansi::a]\n"] |
|
lappend chunklist [list result $result] |
|
|
|
if {[punk::nav::fs::system::codethread_is_running]} { |
|
if {![tsv::llength repl runchunks-$repl_runid]} { |
|
#set ::punk::last_run_display $chunklist |
|
tsv::lappend repl runchunks-$repl_runid {*}$chunklist |
|
} |
|
if {[llength [info commands ::punk::console::titleset]]} { |
|
catch {::punk::console::titleset [lrange $result 1 end]} ;#strip location key |
|
} |
|
} |
|
if {$repl_runid == 0} { |
|
punk::nav::fs::system::emit_chunklist $chunklist |
|
} |
|
return $result |
|
} |
|
|
|
proc d/new {args} { |
|
if {![llength $args]} { |
|
error "usage: d/new <dir> \[<dir> ...\]" |
|
} |
|
set a1 [lindex $args 0] |
|
set curdir [pwd] |
|
set path1 [path_to_absolute $a1 $curdir $::tcl_platform(platform)] |
|
set fullpath [file join $path1 {*}[lrange $args 1 end]] |
|
|
|
if {[file exists $fullpath]} { |
|
error "Folder $fullpath already exists" |
|
} |
|
file mkdir $fullpath |
|
d/ $fullpath |
|
} |
|
|
|
#todo use unknown to allow d/~c:/etc ?? |
|
proc d/~ {args} { |
|
set home $::env(HOME) |
|
set target [file join $home {*}$args] |
|
if {![file isdirectory $target]} { |
|
error "Folder $target not found" |
|
} |
|
d/ $target |
|
} |
|
|
|
|
|
#run a file |
|
proc x/ {args} { |
|
if {![llength $args]} { |
|
set result [d/] |
|
append result \n "x/ <cmd> ?args?" |
|
return $result |
|
} |
|
set curdir [pwd] |
|
#todo - allow wish for those who want it.. but in punk we try to use tclsh or a kit and load Tk as a library |
|
set scriptconfig [dict create\ |
|
tcl [list exe tclsh extensions [list ".tcl" ".tm" ".tk" ".kit"]]\ |
|
python [list exe python extensions [list ".py"]]\ |
|
lua [list exe lua extensions [list ".lua"]]\ |
|
perl [list exe perl extensions [list ".pl"]]\ |
|
php [list exe php extensions [list ".php"]]\ |
|
] |
|
set tcl_extensions [list ".tcl" ".tm" ".kit" ".tk"] ;#todo - load from config |
|
set py_extensions [list ".py"] |
|
set lua_extensions [list ".lua"] |
|
set perl_extensions [list ".pl"] |
|
|
|
set script_extensions [list] |
|
set extension_lookup [dict create] |
|
tcl::dict::for {lang langinfo} $scriptconfig { |
|
set extensions [dict get $langinfo extensions] |
|
lappend script_extensions {*}$extensions |
|
foreach e $extensions { |
|
dict set extension_lookup $e $lang ;#provide reverse lookup |
|
} |
|
} |
|
|
|
#some executables (e.g tcl) can use arguments prior to the script |
|
#use first entry on commandline for which a file exists *and has a script extension - or is executable* as the script to run |
|
#we can't always just assume that first existant file on commandline is the one being run, as it might be config file |
|
#e.g php -c php.ini -f script.php |
|
set scriptlang "" |
|
set scriptfile "" |
|
foreach a $args { |
|
set ext [file extension $a] |
|
if {$ext in $script_extensions && [file exists $a]} { |
|
set scriptlang [dict get $extension_lookup $ext] |
|
set scriptfile $a |
|
break |
|
} |
|
} |
|
puts "scriptlang: $scriptlang scriptfile:$scriptfile" |
|
|
|
#todo - allow sh scripts with no extension ... look at shebang etc? |
|
if {$scriptfile ne "" && $scriptlang ne ""} { |
|
set path [path_to_absolute $scriptfile $curdir $::tcl_platform(platform)] |
|
if {[file type $path] eq "file"} { |
|
set ext [file extension $path] |
|
set extlower [string tolower $ext] |
|
if {$extlower in $tcl_extensions} { |
|
set newargs [lrange $args 1 end] ;#todo - fix to allow script in position other than first |
|
set ::argv0 $path |
|
set ::argc [llength $newargs] |
|
set ::argv $newargs |
|
tailcall source $path |
|
} elseif {$extlower in $py_extensions} { |
|
set pycmd [auto_execok python] |
|
tailcall {*}$pycmd {*}$args |
|
} elseif {$extlower in $script_extensions} { |
|
set exename [dict get $scriptconfig $scriptlang exe] |
|
set cmd [auto_execok $exename] |
|
tailcall {*}$cmd $args |
|
} else { |
|
set fd [open $path r] |
|
set chunk [read $fd 4000]; close $fd |
|
#consider any commented line near top of file containing 'tcl' as likely to be a tcl script of some sort and attempt to source it. |
|
set toplines [split $chunk \n] |
|
set tcl_indicator 0 |
|
foreach ln $toplines { |
|
set ln [string trim $ln] |
|
if {[string match "#*tcl*" $ln]} { |
|
set tcl_indicator 1 |
|
break |
|
} |
|
} |
|
if {$tcl_indicator} { |
|
set newargs [lrange $args 1 end] ;#todo - fix to allow script in position other than first. |
|
set ::argv0 $path |
|
set ::argc [llength $newargs] |
|
set ::argv $newargs |
|
tailcall source $path |
|
} |
|
puts stderr "Cannot run [file extension $path] file directly ([file tail $path]) as tcl script. Ensure file has a known tcl extension ($tcl_extensions) or add a commented hint in the file such as #!/usr/bin/env tclsh" |
|
return [pwd] |
|
} |
|
} |
|
} else { |
|
puts stderr "No script executable known for this" |
|
} |
|
|
|
} |
|
|
|
|
|
proc dirlist {{location ""}} { |
|
set contents [dirfiles_dict -with_times {f d l} -with_sizes {f d l} $location] |
|
return [dirfiles_dict_as_lines -stripbase 1 $contents] |
|
} |
|
|
|
|
|
#dirfiles dirfiles_dict always deliberately return absolute *unnormalized* path |
|
#e.g when cwd is c:/repo/jn/punk dirfiles ../../ will return something like: |
|
# c:/repo/jn/punk/../../blah |
|
#dirfiles assumes we don't have glob chars in the filenames or paths - dirfiles_dict can be called directly with explicit -tailglob in the rare case that assumption doesn't hold |
|
# dirfiles will test last segment (tail) of supplied searchspecs for fileness vs folderness (when no globchars present in tail) so that it can pass the appropriate flags downstream |
|
proc dirfiles {args} { |
|
set argspecs { |
|
-stripbase -default 1 -type boolean |
|
-formatsizes -default 1 -type boolean -help "Format file size numbers for clarity" |
|
*values -min 0 -max -1 |
|
} |
|
set argd [punk::args::get_dict $argspecs $args] |
|
lassign [dict values $argd] opts values_dict |
|
|
|
set opt_stripbase [dict get $opts -stripbase] |
|
set opt_formatsizes [dict get $opts -formatsizes] |
|
|
|
#todo - support multiple searchspecs - dirfiles_dict should merge results when same folder |
|
set searchspec "" |
|
dict for {_index val} $values_dict { |
|
set searchspec $val |
|
break |
|
} |
|
|
|
set relativepath [expr {[file pathtype $searchspec] eq "relative"}] |
|
set has_tailglobs [regexp {[?*]} [file tail $searchspec]] |
|
|
|
#dirfiles_dict would handle simple cases of globs within paths anyway - but we need to explicitly set tailglob here in all branches so that next level doesn't need to do file vs dir checks to determine user intent. |
|
#(dir-listing vs file-info when no glob-chars present is inherently ambiguous so we test file vs dir to make an assumption - more explicit control via -tailglob can be done manually with dirfiles_dict) |
|
if {$relativepath} { |
|
set searchbase [pwd] |
|
if {!$has_tailglobs} { |
|
if {[file isdirectory [file join $searchbase $searchspec]]} { |
|
set location [file join $searchbase $searchspec] |
|
set tailglob * |
|
} else { |
|
set location [file dirname [file join $searchbase $searchspec]] |
|
set tailglob [file tail $searchspec] ;#use exact match as a glob - will retrieve size,attributes etc. |
|
} |
|
} else { |
|
#tailglobs exist - and we operate under assumption globchars aren't present in file/folder names - so no folderness/fileness check needed. |
|
set location [file dirname [file join $searchbase $searchspec]] |
|
set tailglob [file tail $searchspec] |
|
} |
|
} else { |
|
#for absolute paths - searchbase AND location will change depending on globiness of tail and fileness vs folderness |
|
if {!$has_tailglobs} { |
|
if {[file isdirectory $searchspec]} { |
|
set searchbase $searchspec |
|
set location $searchspec |
|
set tailglob * |
|
} else { |
|
set searchbase [file dirname $searchspec] |
|
set location [file dirname $searchspec] |
|
set tailglob [file tail $searchspec] ;#literal glob for single file - retrieves properties |
|
} |
|
} else { |
|
set searchbase [file dirname $searchspec] |
|
set location [file dirname $searchspec] |
|
set tailglob [file tail $searchspec] |
|
} |
|
} |
|
puts "--> -searchbase:$searchbase searchspec:$searchspec -tailglob:$tailglob location:$location" |
|
set contents [dirfiles_dict -searchbase $searchbase -tailglob $tailglob -with_times {f d l} -with_sizes {f d l} $location] |
|
return [dirfiles_dict_as_lines -stripbase $opt_stripbase -formatsizes $opt_formatsizes $contents] |
|
} |
|
|
|
#todo - package as punk::nav::fs |
|
#todo - in thread |
|
#todo - streaming version |
|
#glob patterns in path prior to final segment should already be resolved before using dirfiles_dict - as the underlying filesystem mechanisms can't do nested globbing themselves. |
|
#dirfiles_dict will assume the path up to the final segment is literal even if globchars are included therein. |
|
#final segment globs will be recognised only if -tailglob is passed as empty string |
|
#if -tailglob not supplied and last segment has globchars - presume searchspec parendir is the container and last segment is globbing within that. |
|
#if -tailglob not supplied and last segment has no globchars - presume searchspec is a container(directory) and use glob * |
|
#caller should use parentdir as location and set tailglob to search-pattern or exact match if location is intended to match a file rather than a directory |
|
#examples: |
|
# somewhere/files = search is effectively somewhere/files/* (location somewhere/files glob is *) |
|
# somewhere/files/* = (as above) |
|
# -tailglob * somewhere/files = (as above) |
|
# |
|
# -tailglob "" somewhere/files = search somewhere folder for exactly 'files' (location somewhere glob is files) |
|
# -tailglob files somewhere = (as above) |
|
# |
|
# somewhere/f* = search somewhere folder for f* (location somewhere glob is f*) |
|
# -tailglob f* somewhere = (as above) |
|
# |
|
# This somewhat clumsy API is so that simple searches can be made in a default sensible manner without requiring extra -tailglob argument for the common cases - with lack of trailing glob segment indicating a directory listing |
|
# - but we need to distinguish somewhere/files as a search of that folder vs somewhere/files as a search for exactly 'files' within somewhere, hence the -tailglob option to fine-tune. |
|
# - this also in theory allows file/directory names to contain glob chars - although this is probably unlikely and/or unwise and not likely to be usable on all platforms. |
|
# |
|
#if caller supplies a tailglob as empty string - presume the caller hasn't set location to parentdir - and that last element is the search pattern. |
|
# -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied |
|
proc dirfiles_dict {args} { |
|
set argspecs { |
|
*opts -any 0 |
|
-searchbase -default "" |
|
-tailglob -default "\uFFFF" |
|
#with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du) |
|
-with_sizes -default "\uFFFF" -type string |
|
-with_times -default "\uFFFF" -type string |
|
*values -min 0 -max -1 -type string |
|
} |
|
set argd [punk::args::get_dict $argspecs $args] |
|
lassign [dict values $argd] opts vals |
|
set searchspecs [dict values $vals] |
|
|
|
#puts stderr "searchspecs: $searchspecs [llength $searchspecs]" |
|
#puts stdout "arglist: $opts" |
|
|
|
if {[llength $searchspecs] > 1} { |
|
#review - spaced paths ? |
|
error "dirfiles_dict: multiple listing not *yet* supported" |
|
} |
|
set searchspec [lindex $searchspecs 0] |
|
# -- --- --- --- --- --- --- |
|
set opt_searchbase [dict get $opts -searchbase] |
|
set opt_tailglob [dict get $opts -tailglob] |
|
set opt_with_sizes [dict get $opts -with_sizes] |
|
set opt_with_times [dict get $opts -with_times] |
|
# -- --- --- --- --- --- --- |
|
|
|
#we don't want to normalize.. |
|
#for example if the user supplies ../ we want to see ../result |
|
|
|
set is_relativesearchspec [expr {[file pathtype $searchspec] eq "relative"}] |
|
if {$opt_searchbase eq ""} { |
|
set searchbase . |
|
} else { |
|
set searchbase $opt_searchbase |
|
} |
|
|
|
|
|
switch -- $opt_tailglob { |
|
"" { |
|
if {$searchspec eq ""} { |
|
set location |
|
} else { |
|
if {$is_relativesarchspec} { |
|
#set location [file dirname [file join $opt_searchbase $searchspec]] |
|
set location [punk::path::normjoin $searchbase $searchspec ..] |
|
} else { |
|
set location [punk::path::normjoin $searchspec ..] |
|
} |
|
#here tail is treated as a search-pattern within location whether or not it contains glob chars "?" or "*" |
|
set match_contents [file tail $searchspec] |
|
} |
|
} |
|
"\uFFFF" { |
|
set searchtail_has_globs [regexp {[*?]} [file tail $searchspec]] |
|
if {$searchtail_has_globs} { |
|
if {$is_relativesearchspec} { |
|
#set location [file dirname [file join $searchbase $searchspec]] |
|
#e.g subdir/* or sub/etc/x* |
|
set location [punk::path::normjoin $searchbase $searchspec ..] |
|
} else { |
|
set location [punk::path::normjoin $searchspec ..] |
|
} |
|
set match_contents [file tail $searchspec] |
|
} else { |
|
#user didn't supply a glob within tail segment, nor did they specify a separate -tailglob - presume they want a directory listing |
|
if {$searchspec eq ""} { |
|
set location $searchbase |
|
} else { |
|
if {$is_relativesearchspec} { |
|
#set location [file join $searchbase $searchspec] |
|
set location [punk::path::normjoin $searchbase $searchspec] |
|
} else { |
|
#absolute path for search |
|
set location $searchspec |
|
} |
|
} |
|
set match_contents * |
|
} |
|
} |
|
default { |
|
#-tailglob supplied separately - ignore any globiness in tail segment of searchspec and treat literally |
|
if {$searchspec eq ""} { |
|
set location $searchbase |
|
} else { |
|
if {$is_relativesearchspec} { |
|
#set location [file join $searchbase $searchspec] |
|
set location [punk::path::normjoin $searchbase $searchspec] |
|
} else { |
|
set location $searchspec |
|
} |
|
} |
|
set match_contents $opt_tailglob |
|
} |
|
} |
|
#puts stdout "searchbase: $searchbase searchspec:$searchspec" |
|
|
|
|
|
#file attr //cookit:/ returns {-vfs 1 -handle {}} |
|
#we will treat it differently for now - use generic handler REVIEW |
|
set in_vfs 0 ;#we use this only for a vfs which is reported to have a mountpoint by vfs::filesystem info - not all that have -vfs 1 attr like cookit. |
|
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 |
|
break |
|
} |
|
} |
|
} |
|
|
|
if {$opt_with_sizes eq "\uFFFF"} { |
|
#leave up to listing-provider defaults |
|
set next_opt_with_sizes "" |
|
} else { |
|
set next_opt_with_sizes [list -with_sizes $opt_with_sizes] |
|
} |
|
if {$opt_with_times eq "\uFFFF"} { |
|
#leave up to listing-provider defaults |
|
set next_opt_with_times "" |
|
} else { |
|
set next_opt_with_times [list -with_times $opt_with_times] |
|
} |
|
if {$in_vfs} { |
|
set listing [punk::du::lib::du_dirlisting_tclvfs $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] |
|
} else { |
|
set in_zipfs 0 |
|
set in_cookit 1 |
|
set in_other_pseudovol 1 |
|
switch -glob -- $location { |
|
//zipfs:/* { |
|
if {[info commands ::tcl::zipfs::mount] ne ""} { |
|
set in_zipfs 1 |
|
} |
|
} |
|
//cookit:/* { |
|
set in_cookit 1 |
|
} |
|
default { |
|
#handle 'other/unknown' that mounts at a volume-like path //pseudovol:/ |
|
if {[regexp {//((?:(?!:|/).)+):/.*} $location _match pseudovol]} { |
|
#pseudovol probably more than one char long |
|
#we don't really expect something like //c:/ , but anyway, it's not the same as c:/ and for all we know someone could use that as a volume name? |
|
set in_other_pseudovol 1 ;#flag so we don't use twapi - hope generic can handle it (uses tcl glob) |
|
} else { |
|
#we could use 'file attr' here to test if {-vfs 1} |
|
#but it's an extra filesystem hit on all normal paths too (which can be expensive on some systems) |
|
#instead for now we'll assume any reasonable vfs should have been found by vfs::filesystem::info or mounted as a pseudovolume |
|
} |
|
|
|
} |
|
} |
|
|
|
if {$in_zipfs} { |
|
#relative vs absolute? review - cwd valid for //zipfs:/ ?? |
|
set listing [punk::du::lib::du_dirlisting_zipfs $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] |
|
} elseif {$in_cookit} { |
|
#seems to be a vfs - except it mounts on a pseudo-volume path //cookit:/ |
|
#don't use twapi |
|
#could possibly use du_dirlisting_tclvfs REVIEW |
|
#files and folders are all returned with the -types hidden option for glob on windows |
|
set listing [punk::du::lib::du_dirlisting_generic $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] |
|
} elseif {$in_other} { |
|
set listing [punk::du::lib::du_dirlisting_generic $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] |
|
} else { |
|
set listing [punk::du::dirlisting $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] |
|
} |
|
} |
|
|
|
set dirs [dict get $listing dirs] |
|
set files [dict get $listing files] |
|
set filesizes [dict get $listing filesizes] |
|
set vfsmounts [dict get $listing vfsmounts] |
|
set flaggedhidden [dict get $listing flaggedhidden] |
|
|
|
|
|
set nonportable [list] ;#illegal file/folder names for windows e.g trailing dot or trailing space - can still be read if //?/ AND shortname used |
|
set underlayfiles [list] |
|
set underlayfilesizes [list] |
|
if {[llength $vfsmounts]} { |
|
foreach vfsmount $vfsmounts { |
|
if {[set fposn [lsearch $files $vfsmount]] >= 0} { |
|
lappend underlayfiles [lindex $files $fposn] |
|
set files [lreplace $files $fposn $fposn] |
|
#for any change to files list must change filesizes too if list exists |
|
if {[llength $filesizes]} { |
|
lappend underlayfilesizes [lindex $filesizes $fposn] |
|
set filesizes [lreplace $filesizes $fposn $fposn] |
|
} |
|
lappend dirs $vfsmount |
|
} elseif {$vfsmount in $dirs} { |
|
#either dirlisting mech was aware of vfs.. or mountpoint is overlaying an underlying folder |
|
#for now - do nothing |
|
#todo - review. way to query dirlisting mech to see if we are hiding a folder? |
|
|
|
} else { |
|
#vfs mount but dirlisting mechanism didn't detect as file or folder |
|
lappend dirs $vfsmount |
|
} |
|
} |
|
} |
|
|
|
|
|
#NOTE: -types {hidden d} * may return . & .. on unix platforms - but will not show them on windows. |
|
#A mounted vfs exe (e.g sometclkit.exe) may be returned by -types {hidden d} on windows - but at the same time has "-hidden 0" in the result of file attr. |
|
|
|
#non-unix platforms may have attributes to indicate hidden status even if filename doesn't have leading dot. |
|
#mac & windows have these |
|
#windows doesn't consider dotfiles as hidden - mac does (?) |
|
#we add dotfiles to flaggedhidden list in case there is some other mechanism that has flagged items as hidden |
|
if {$::tcl_platform(platform) ne "windows"} { |
|
lappend flaggedhidden {*}[lsearch -all -inline [list {*}$dirs {*}$files] ".*"] |
|
#e.g we can have dupes in the case where there are vfs mounted files that appear as dirs |
|
#as we will need to do a (nat)sort as a last step - it will be faster to not sort items prematurely |
|
#set flaggedhidden [lsort -unique $flaggedhidden] |
|
set flaggedhidden [punk::lib::lunique_unordered $flaggedhidden] |
|
} |
|
|
|
set dirs [lsort $dirs] ;#todo - natsort |
|
|
|
|
|
|
|
#foreach d $dirs { |
|
# if {[lindex [file system $d] 0] eq "tclvfs"} { |
|
# lappend vfs $d [file system $d] |
|
# } |
|
#} |
|
|
|
#glob -types {hidden} will not always return the combination of glob -types {hidden f} && -types {hidden d} (on windows anyway) |
|
|
|
# -- --- |
|
#can't lsort files without lsorting filesizes |
|
#Note - the sort by index would convert an empty filesizes list to a list of empty strings - one for each entry in files |
|
#We want to preserve the empty list if that's what the dirlisting mechanism returned (presumably because -with_sizes was 0 or explicitly excluded files) |
|
if {[llength $filesizes] == 0} { |
|
set sorted_files [lsort $files] |
|
set sorted_filesizes [list] |
|
} else { |
|
set sortorder [lsort -indices $files] |
|
set sorted_files [list] |
|
set sorted_filesizes [list] |
|
foreach i $sortorder { |
|
lappend sorted_files [lindex $files $i] |
|
lappend sorted_filesizes [lindex $filesizes $i] |
|
} |
|
} |
|
|
|
set files $sorted_files |
|
set filesizes $sorted_filesizes |
|
# -- --- |
|
|
|
|
|
#jmn |
|
foreach nm [list {*}$dirs {*}$files] { |
|
if {[punk::winpath::illegalname_test $nm]} { |
|
lappend nonportable $nm |
|
} |
|
} |
|
set front_of_dict [dict create location $location searchbase $opt_searchbase] |
|
set listing [dict merge $front_of_dict $listing] |
|
|
|
set updated [dict create dirs $dirs files $files filesizes $filesizes nonportable $nonportable flaggedhidden $flaggedhidden underlayfiles $underlayfiles underlayfilesizes $underlayfilesizes] |
|
return [dict merge $listing $updated] |
|
} |
|
|
|
#todo - color key via repl-telemetry? help command? documentation? or add tag columns as done in namespace listing? |
|
proc dirfiles_dict_as_lines {args} { |
|
package require overtype |
|
|
|
set argspecs { |
|
-stripbase -default 0 -type boolean |
|
-formatsizes -default 1 -type boolean |
|
*values -min 1 -max -1 -type dict |
|
} |
|
set argd [punk::args::get_dict $argspecs $args] |
|
lassign [dict values $argd] opts vals |
|
set list_of_dicts [dict values $vals] |
|
|
|
|
|
|
|
# -- --- --- --- --- --- --- --- --- --- --- --- |
|
set opt_stripbase [dict get $opts -stripbase] |
|
set opt_formatsizes [dict get $opts -formatsizes] |
|
# -- --- --- --- --- --- --- --- --- --- --- --- |
|
|
|
#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] |
|
} |
|
|
|
set fkeys [dict create] ;#avoid some file normalize calls.. |
|
if {$opt_stripbase && $common_base ne ""} { |
|
set filetails [list] |
|
set dirtails [list] |
|
foreach fileset [list dirs files links underlayfiles flaggedhidden flaggedreadonly flaggedsystem nonportable vfsmounts] { |
|
set stripped [list] |
|
foreach fullname [set $fileset] { |
|
set shortname [strip_prefix_depth $fullname $common_base] |
|
dict set fkeys $shortname $fullname ;#cache so we can retrieve already normalised name without re-hitting filesystem |
|
lappend stripped $shortname |
|
} |
|
set $fileset $stripped |
|
} |
|
#Note: without fkeys we would need to remember to use common_base to rebuild (and file normalize!) the key when we need to query the dict-based elements: sizes & times - because we didn't strip those keys. |
|
} |
|
|
|
# -- --- --- --- --- --- --- --- --- --- --- |
|
#assign symlinks to the dirs or files collection (the punk::du system doesn't sort this out |
|
#As at 2024-09 for windows symlinks - Tcl can't do file readlink on symlinks created with mklink /D name target (SYMLINKD) or mklink name target (SYMLINK) |
|
#We can't read the target information - best we can do is classify it as a file or a dir |
|
#we can't use 'file type' as that will report just 'link' - but file isfile and file isdirectory work and should work for links on all platforms - REVIEW |
|
set file_symlinks [list] |
|
set dir_symlinks [list] |
|
set dir_shortcuts [list] ;#windows shell links (.lnk) that have a target that is a directory |
|
foreach s $links { |
|
if {[dict exists $contents linkinfo $s target_type]} { |
|
#some mechanisms such as twapi can provide the target_type info so we don't have to re-hit the filesystem. |
|
set target_type [dict get $contents linkinfo $s target_type] |
|
switch -- $target_type { |
|
file { |
|
lappend file_symlinks $s |
|
} |
|
directory { |
|
lappend dir_symlinks $s |
|
lappend dirs $s |
|
} |
|
default { |
|
puts stderr "Warning - cannot determine link type for link $s (target_type value is:$target_type)" |
|
} |
|
} |
|
} else { |
|
#fallback if no target_type |
|
if {[file isfile $s]} { |
|
lappend file_symlinks $s |
|
#will be appended in finfo_plus later |
|
} elseif {[file isdirectory $s]} { |
|
lappend dir_symlinks $s |
|
lappend dirs $s |
|
} else { |
|
#dunno - warn for now |
|
puts stderr "Warning - cannot determine link type for link $s" |
|
} |
|
} |
|
} |
|
#we now have the issue that our symlinks aren't sorted within the dir/file categorisation - they currently will have to appear at beginning or end - TODO |
|
# -- --- --- --- --- --- --- --- --- --- --- |
|
|
|
|
|
#todo - sort whilst maintaining order for metadata? |
|
#we need to co-sort files only with filesizes (other info such as times is keyed on fname so cosorting not required) |
|
|
|
|
|
#we can't sort on filesize after format_number (unless we were to enforce delim _ which we don't want to do) |
|
if {$opt_formatsizes} { |
|
set filesizes [punk::lib::format_number $filesizes] ;#accepts a list and will process each |
|
} |
|
|
|
#col2 (file info) with subcolumns |
|
|
|
set widest2a [tcl::mathfunc::max {*}[lmap v [list {*}$files {*}$file_symlinks ""] {string length $v}]] |
|
|
|
set c2a [string repeat " " [expr {$widest2a + 1}]] |
|
#set widest2b [punk::pipedata [list {*}$filesizes ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] |
|
set widest2b [tcl::mathfunc::max {*}[lmap v [list {*}$filesizes ""] {string length $v}]] |
|
set c2b [string repeat " " [expr {$widest2b + 1}]] |
|
|
|
#c2c timestamp and short note - fixed width 19 for ts + <sp> + filetype note e.g "symlink" "shortcut" "binary" ?? combinations? allow 2 words 10 each for 21 + 1 for luck |
|
# total 42 |
|
set c2c [string repeat " " 42] |
|
set finfo [list] |
|
foreach f $files s $filesizes { |
|
if {[dict size $fkeys]} { |
|
set key [dict get $fkeys $f] |
|
} else { |
|
#not stripped - they should match |
|
set key $f |
|
} |
|
#note - the display entry isn't necessarily a valid tcl list e.g filename with unbalanced curly braces |
|
#hence we need to keep the filename as well, properly protected as a list element |
|
if {[dict exists $contents times $key m]} { |
|
set mtime [dict get $contents times $key m] |
|
set ts [tcl::clock::format $mtime -format "%Y-%m-%d %H:%M:%S"] |
|
} else { |
|
#set ts [string repeat { } 19] |
|
set ts "$key vs [dict keys [dict get $contents times]]" |
|
} |
|
set note "" |
|
lappend finfo [list file $f display "[overtype::left $c2a $f] [overtype::right $c2b $s] [overtype::left $c2c "$ts $note"]"] |
|
} |
|
set flink_style [punk::ansi::a+ undercurly underline undt-green] ;#curly green underline with fallback to normal underline |
|
set dlink_style [punk::ansi::a+ undercurly underline undt-green] |
|
#We use an underline so the visual styling of a link can coexist with fg/bg colors applied for other attributes such as hidden |
|
foreach flink $file_symlinks { |
|
if {[dict size $fkeys]} { |
|
set key [dict get $fkeys $flink] |
|
} else { |
|
set key $flink |
|
} |
|
if {[dict exists $contents times $key m]} { |
|
set mtime [dict get $contents times $key m] |
|
set ts [tcl::clock::format $mtime -format "%Y-%m-%d %H:%M:%S"] |
|
} else { |
|
set ts "[string repeat { } 19]" |
|
} |
|
set note "link" ;#default only |
|
if {[dict exists $contents linkinfo $key linktype]} { |
|
if {[dict get $contents linkinfo $key linktype] eq "reparse_point"} { |
|
set note "reparse_point" |
|
if {[dict exists $contents linkinfo $key reparseinfo tag]} { |
|
append note " " [dict get $contents linkinfo $key reparseinfo tag] |
|
} |
|
} else { |
|
append note "$key vs [dict keys [dict get $contents linkinfo]]" |
|
} |
|
} |
|
lappend finfo [list file $flink display "$flink_style[overtype::left $c2a $flink] [overtype::right $c2b 0] [overtype::left $c2c "$ts $note"]"] |
|
} |
|
|
|
set fshortcut_style [punk::ansi::a+ underdotted underline undt-hotpink] |
|
set dshortcut_style [punk::ansi::a+ underdotted underline undt-hotpink] |
|
#examine windows .lnk shell link files (shortcuts) - these could be encountered on other platforms too - we should still be able to read them |
|
#review - symlink to shortcut? hopefully will just work |
|
#classify as file or directory - fallback to file if unknown/undeterminable |
|
set finfo_plus [list] |
|
foreach fdict $finfo { |
|
set fname [dict get $fdict file] |
|
if {[file extension $fname] eq ".lnk"} { |
|
if {![catch {package require punk::winlnk}]} { |
|
set shortcutinfo [punk::winlnk::file_get_info $fname] |
|
set target_type "file" ;#default/fallback |
|
if {[dict exists $shortcutinfo link_target]} { |
|
set is_valid_lnk 1 |
|
set tgt [dict get $shortcutinfo link_target] |
|
if {[file exists $tgt]} { |
|
#file type could return 'link' - we will use isfile/isdirectory |
|
if {[file isfile $tgt]} { |
|
set target_type file |
|
} elseif {[file isdirectory $tgt]} { |
|
set target_type directory |
|
} else { |
|
set target_type file ;## ? |
|
} |
|
} else { |
|
#todo - see if punk::winlnk has info about the type at the time of linking |
|
#for now - treat as file |
|
} |
|
} else { |
|
#no link_target - probably an ordinary file - but there could have been some other error in reading the binary windows lnk format. |
|
set is_valid_lnk 0 |
|
} |
|
if {$is_valid_lnk} { |
|
switch -- $target_type { |
|
file { |
|
set display [dict get $fdict display] |
|
set display "$fshortcut_style$display (shortcut $tgt)" ;# |
|
dict set fdict display $display |
|
lappend finfo_plus $fdict |
|
} |
|
directory { |
|
#target of link is a dir - for display/categorisation purposes we want to see it as a dir |
|
#will be styled later based on membership of dir_shortcuts |
|
lappend dirs $fname |
|
lappend dir_shortcuts $fname |
|
} |
|
} |
|
} else { |
|
#we were unable to get link_target - but we still need to check if it failed the header check (then assume not intended to be a windows shell lnk) or for some other reason. |
|
if {[dict exists $shortcutinfo error]} { |
|
if {[dict get $shortcutinfo error] ne "lnk_header_check_failed"} { |
|
#Presumably there is a valid lnk header, but some unexpected error occurred - show it in the display for the file |
|
#still style as a windows shell lnk - as to get here, the header check must have passed. |
|
set display [dict get $fdict display] |
|
set display "$fshortcut_style$display (shortcut error [dict get $shortcutinfo error])" ;# |
|
dict set fdict display $display |
|
lappend finfo_plus $fdict |
|
} else { |
|
#error of lnk_header_check_failed means it probably just isn't a windows shell link. Leave ordinary display for file. |
|
lappend finfo_plus $fdict |
|
} |
|
} else { |
|
#shouldn't ever happen. If no error, then there should have been a link_target |
|
#report and move on |
|
puts stderr "Unexpected error in result of parsing binary format for $fname" |
|
lappend finfo_plus $fdict |
|
} |
|
} |
|
#assert - we have either appended to finfo_plus (possibly with shortcut info/error if binary header was valid) - or appended to dirs (if it was a valid lnk and target was a dir) |
|
} |
|
#if we don't have punk::winlnk to read the .lnk - it will get no special highlighting and just appear as an ordinary file even if it points to a dir |
|
} else { |
|
lappend finfo_plus $fdict |
|
} |
|
} |
|
unset finfo |
|
|
|
|
|
|
|
#set widest1 [punk::pipedata [list {*}$dirs ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] |
|
#set widest1 [tcl::mathfunc::max {*}[lmap v [concat $dirs [list ""]] {string length $v}]] |
|
set widest1 [tcl::mathfunc::max {*}[lmap v [list {*}$dirs ""] {string length $v}]] |
|
|
|
set displaylist [list] |
|
set col1 [string repeat " " [expr {$widest1 + 2}]] |
|
set RST [punk::ansi::a] |
|
foreach d $dirs filerec $finfo_plus { |
|
set d1 [punk::ansi::a+ cyan bold] |
|
set d2 [punk::ansi::a+ defaultfg defaultbg normal] |
|
#set f1 [punk::ansi::a+ white bold] |
|
set f1 [punk::ansi::a+ white] |
|
set f2 [punk::ansi::a+ defaultfg defaultbg normal] |
|
set fdisp "" |
|
if {[string length $d]} { |
|
if {$d in $flaggedhidden} { |
|
set d1 [punk::ansi::a+ cyan normal] |
|
} |
|
if {$d in $vfsmounts} { |
|
if {$d in $flaggedhidden} { |
|
#we could have a hidden dir which is also a vfs.. colour will be overridden giving no indicatio of 'hidden' status - REVIEW |
|
#(This situation encountered on windows - even though file attr showed -hidden 0 - the glob with -types hidden returned it.. possibly a tcl glob bug on windows) |
|
#mark it differently for now.. (todo bug report?) |
|
if {$d in $nonportable} { |
|
set d1 [punk::ansi::a+ red Yellow bold] |
|
} else { |
|
set d1 [punk::ansi::a+ green Purple bold] |
|
} |
|
} else { |
|
if {$d in $nonportable} { |
|
set d1 [punk::ansi::a+ red White bold] |
|
} else { |
|
set d1 [punk::ansi::a+ green bold] |
|
} |
|
} |
|
} else { |
|
if {$d in $nonportable} { |
|
set d1 [punk::ansi::a+ red bold] |
|
} |
|
} |
|
#dlink-style & dshortcut_style are for underlines - can be added with colours already set |
|
if {$d in $dir_symlinks} { |
|
append d1 $dlink_style |
|
} elseif {$d in $dir_shortcuts} { |
|
append d1 $dshortcut_style |
|
} |
|
} |
|
if {[llength $filerec]} { |
|
set fname [dict get $filerec file] |
|
set fdisp [dict get $filerec display] |
|
if {$fname in $flaggedhidden} { |
|
set f1 [punk::ansi::a+ Purple] |
|
} else { |
|
if {$fname in $nonportable} { |
|
set f1 [punk::ansi::a+ red bold] |
|
} |
|
} |
|
} |
|
lappend displaylist [overtype::left $col1 $d1$d$RST]$f1$fdisp$RST |
|
} |
|
|
|
return [punk::lib::list_as_lines $displaylist] |
|
} |
|
|
|
#pass in base and platform to head towards purity/testability. |
|
#this function can probably never be pure in such a simple form - as it needs to read state from the os storage system configuration |
|
#consider haskells approach of well-typed paths for cross-platform paths: https://hackage.haskell.org/package/path |
|
#review: punk::winpath calls cygpath! |
|
#review: file pathtype is platform dependant |
|
proc path_to_absolute {path base platform} { |
|
set ptype [file pathtype $path] |
|
if {$ptype eq "absolute"} { |
|
set path_absolute $path |
|
} elseif {$ptype eq "volumerelative"} { |
|
if {$platform eq "windows"} { |
|
#unix looking paths like /c/users or /usr/local/etc are reported by tcl as volumerelative.. (as opposed to absolute on unix platforms) |
|
if {[string index $path 0] eq "/"} { |
|
#this conversion should be an option for the ./ command - not built in as a default way of handling volumerelative paths here |
|
#It is more useful on windows to treat /usr/local as a wsl or mingw path - and may be reasonable for ./ - but is likely to surprise if put into utility functions. |
|
#Todo - tidy up. |
|
package require punk::unixywindows |
|
set path_absolute [punk::unixywindows::towinpath $path] |
|
#puts stderr "winpath: $path" |
|
} else { |
|
#todo handle volume-relative paths with volume specified c:etc c: |
|
#note - tcl doesn't handle this properly anyway.. the win32 api should 'remember' the per-volume cwd |
|
#not clear whether tcl can/will fix this - but it means these paths are dangerous. |
|
#The cwd of the process can get out of sync with what tcl thinks is the working directory when you swap drives |
|
#Arguably if ...? |
|
|
|
#set path_absolute $base/$path |
|
set path_absolute $path |
|
} |
|
} else { |
|
# unknown what paths are reported as this on other platforms.. treat as absolute for now |
|
set path_absolute $path |
|
} |
|
} else { |
|
set path_absolute $base/$path |
|
} |
|
if {$platform eq "windows"} { |
|
if {[punk::winpath::illegalname_test $path_absolute]} { |
|
set path_absolute [punk::winpath::illegalname_fix $path_absolute] ;#add dos-device-prefix protection if not already present |
|
} |
|
} |
|
return $path_absolute |
|
} |
|
proc strip_prefix_depth {path prefix} { |
|
set tail [lrange [file split $path] [llength [file split $prefix]] end] |
|
if {[llength $tail]} { |
|
return [file join {*}$tail] |
|
} else { |
|
return "" |
|
} |
|
} |
|
|
|
#REVIEW - at least one version of Tcl during development couldn't navigate using cd to intermediate paths between the zipfs root and the mountpoint. |
|
#TODO - test if this can still occur. |
|
proc Zipfs_path_within_zipfs_mounts {zipfspath} { |
|
if {![string match //zipfs:/* $zipfspath]} {error "Zipfs_path_within_zipfs_mounts error. Supplied zipfspath $zipfspath must be a //zipfs:/* path"} |
|
set is_within_mount 0 |
|
dict for {zmount zpath} [zipfs mount] { |
|
if {[punk::mix::base::lib::path_a_atorbelow_b $zipfspath $zmount]} { |
|
set is_within_mount 1 |
|
break |
|
} |
|
} |
|
return $is_within_mount |
|
} |
|
|
|
|
|
#*** !doctools |
|
#[list_end] [comment {--- end definitions namespace punk::nav::fs ---}] |
|
} |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# Secondary API namespace |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
tcl::namespace::eval punk::nav::fs::lib { |
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
|
tcl::namespace::path [tcl::namespace::parent] |
|
#*** !doctools |
|
#[subsection {Namespace punk::nav::fs::lib}] |
|
#[para] Secondary functions that are part of the API |
|
#[list_begin definitions] |
|
|
|
#proc utility1 {p1 args} { |
|
# #*** !doctools |
|
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
|
# #[para]Description of utility1 |
|
# return 1 |
|
#} |
|
|
|
|
|
|
|
#*** !doctools |
|
#[list_end] [comment {--- end definitions namespace punk::nav::fs::lib ---}] |
|
} |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
#*** !doctools |
|
#[section Internal] |
|
tcl::namespace::eval punk::nav::fs::system { |
|
#*** !doctools |
|
#[subsection {Namespace punk::nav::fs::system}] |
|
#[para] Internal functions that are not part of the API |
|
|
|
#ordinary emission of chunklist when no repl |
|
proc emit_chunklist {chunklist} { |
|
set result "" |
|
foreach record $chunklist { |
|
lassign $record type data |
|
switch -- $type { |
|
stdout { |
|
puts stdout "$data" |
|
} |
|
stderr { |
|
puts stderr $data |
|
} |
|
result {} |
|
default { |
|
puts stdout "$type $data" |
|
} |
|
} |
|
} |
|
return $result |
|
} |
|
|
|
proc codethread_is_running {} { |
|
if {[info commands ::punk::repl::codethread::is_running] ne ""} { |
|
return [punk::repl::codethread::is_running] |
|
} |
|
return 0 |
|
} |
|
|
|
} |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Ready |
|
package provide punk::nav::fs [tcl::namespace::eval punk::nav::fs { |
|
variable pkg punk::nav::fs |
|
variable version |
|
set version 999999.0a1.0 |
|
}] |
|
return |
|
|
|
#*** !doctools |
|
#[manpage_end] |
|
|
|
|