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.
 
 
 
 
 
 

2344 lines
120 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 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin punkshell_module_punk::nav::fs 0 0.1.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 ;#required for testing if pattern is glob and also for the dirfiles_dict command which is used for listing and globbing.
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]
#only lookup user_home once per interp or process
#It can be slightly expensive (for example involving network calls on windows domains)
variable user_home_cache
set user_home_cache ""
#tilde
#These aliases work fine for interactive use - but the result is always a string internal-rep
#interp alias {} ~ {} file join $::env(HOME) ;#HOME must be capitalized to work cross platform (lowercase home works on windows - but probably not elsewhere)
#interp alias {} ~ {} apply {args {file join $::env(HOME) $args}}
namespace eval argdoc {
punk::args::define {
@id -id ::punk::nav::fs::~
@cmd -name "punk::nav::fs::~"\
-summary\
"Return user's home directory as the process sees it"\
-help\
"Return the user's home directory path as the process sees it.
(This is not always the same as ::env(HOME))
With additional arguments, return the path obtained by joining
the user's home directory with the supplied arguments.
usage e.g
cd [~]
(change to user's home)
.// [~] .config
(change to .config directory within the user's home
and list contents.)
equivalently:
gohome .config
(gohome uses the output of ~ to determine the home directory)
If the home directory cannot be determined due to the environment
in which the process is running, an error will be raised, as returning
an empty string is not a useful result and can cause issues if used as a path.
"
@opts
@values -min 0 -max -1
arg -type any -optional 1 -multiple 1
}
}
proc ~ {args} {
#review - HOME may be undefined or have been set to another value by other tools or the parent process.
#The process may even be running in a context where there is no home directory - e.g a container with no users, or a system service context.
#(we may be in a safe interp - which generally won't have env vars or filesystem access)
variable user_home_cache
if {$user_home_cache ne ""} {
set hdir $user_home_cache
#we still need to process args to join them to the home directory - but we can skip all the work of determining the home directory again.
} else {
set hdir ""
if {[catch {auto_execok whoami} whoami_exe]} {
set whoami_exe ""
}
if {$whoami_exe eq ""} {
#try env USER or USERNAME - these are commonly set to the username on many platforms - but may not be set in all contexts.
if {[info exists ::env(USER)]} {
set user $::env(USER)
} elseif {[info exists ::env(USERNAME)]} {
set user $::env(USERNAME)
} else {
set user ""
}
} else {
#set user [exec {*}$whoami_exe]
if {[catch {exec {*}$whoami_exe} user]} {
set user ""
}
}
if {[string trim $user] ne ""} {
#normalize user for use with 'file tildeexpand ~<user>'
#on windows, whoami may return DOMAIN\USER
#for tildeexpand to work, we need to convert this to USER@DOMAIN
if {"windows" eq $::tcl_platform(platform)} {
set parts [split $user "\\"]
#we expect only 1 or 2 parts
if {[llength $parts] == 2} {
lassign $parts domain username
#if we use username@domain format - we get the domain controller's view of our home directory - which can be different from the local machine's view of our home directory.
#e.g file tildeexpand ~jnoble@corp can return a local non existant path like c:/users/jnoble
#but it may be c:/users/jnoble.corp - or c:/users/something_else_entirely depending on how the local machine is configured.
#It may be that the domain controller is correct if it returns a network path like \\server\users\jnoble ??
#Network paths are not necessarily the preferred practive as of 2026 - but may still exist.
#Microsoft is encouraging the use of cloud systems - but it it unknown at this stage what sort of paths can be returned.
#REVIEW
set domainuser "$username@$domain"
#we can run file tildeexpand with username@domain and test if the path is writable
#this reduces the possibility that there happens to be a local user with the same name as the domain user - which would cause us to get the wrong home directory.
if {![catch {file tildeexpand ~$domainuser} path]} {
if {[file writable $path]} {
set user $domainuser
set hdir $path ;#set hdir so we don't re-lookup below.
}
}
if {$hdir eq ""} {
#for now we will use the unqualified username.
set user $username
}
} elseif {[llength $parts] == 1} {
set user [lindex $parts 0]
} else {
#unexpected format - emit warning
puts stderr "Warning: Unexpected format of username '$user' returned by whoami. Expected format 'DOMAIN\\USER' or 'USER'. Unable to determine home directory for this user."
set user ""
}
}
#only enter this branch if hdir wasn't resolved above for windows domain user.
if {$hdir eq "" && $user ne ""} {
#we use file tildeexpand ~user because the intention is stated in the tcl source as:
#* the intent is to retrieve (as on Unix) the system's view
#* of the home irrespective of environment settings of HOME
#* and USERPROFILE.
# - this aligns with our intention here.
if {![catch {file tildeexpand ~$user} path]} {
set hdir [punk::valcopy $path]
} else {
#tcl <= 8.6 may not have file tildeexpand.
#we now have no option but to rely on environment variables - which may not be set or may be set to an incorrect value
#as tcl <= 8.6 needs to be supported - but isn't the primary target we will allow this fallback - but raise a warning as this is not ideal.
puts stderr "punk::nav::fs::~ Warning: Unable to determine home directory for user '$user' using 'file tildeexpand ~$user'. Falling back to environment variables, which may not be set or may be incorrect. Consider upgrading to Tcl 9.0 or later for improved reliability."
if {"windows" eq $::tcl_platform(platform)} {
if {[info exists ::env(USERPROFILE)]} {
set hdir [punk::valcopy $::env(USERPROFILE)]
} else {
set hdir ""
}
} else {
if {[info exists ::env(HOME)]} {
set hdir [punk::valcopy $::env(HOME)]
} else {
set hdir ""
}
}
}
}
}
}
if {$hdir eq ""} {
error "punk::nav::fs::~ Unable to determine home directory for user '$user'. Consider upgrading to Tcl 9.0 or later for improved reliability in home directory detection."
}
file pathtype $hdir ;#flips internal-rep to path
if {![file isdirectory $hdir]} {
#file isdirectory should also return true if the path exists and is a symlink to a directory - but if it doesn't exist at all - or is a file - then we have a problem.
error "punk::nav::fs::~ Determined home directory path '$hdir' does not exist (or is not a directory)."
} else {
if {![file readable $hdir]} {
error "punk::nav::fs::~ Determined home directory path '$hdir' is not readable."
}
}
set user_home_cache $hdir ;#cache only the home directory.
set d $hdir
#use the file join 2-arg optimisation to avoid losing path-rep - probably doesn't give any advantage on all Tcl versions
#review - for what versions does/did the 2-arg version of file join not just return a string?
foreach a $args {
set d [file join $d $a]
}
file pathtype $d
return [punk::valcopy $d]
}
punk::args::define {
@id -id ::punk::nav::fs::d/
@cmd -name punk::nav::fs::d/ -help\
{List directories or directories and files in the current directory or in the
targets specified with the fileglob_or_target glob pattern(s).
If a single target is specified without glob characters, and it exists as a directory,
then the working directory is changed to that target and a listing of that directory
is returned. If the single target specified without glob characters does not exist as
a directory, then it is treated as a glob pattern and the listing is for the current
directory with results filtered to match fileglob_or_target.
If multiple targets or glob patterns are specified, then a separate listing is returned
for each fileglob_or_target pattern.
This function is provided via aliases as ./ and .// with v being inferred from the alias
name, and also as d/ with an explicit v argument.
The ./ and .// forms are more convenient for interactive use.
examples:
./ - list directories in current directory
.// - list directories and files in current directory
./ src/* - list directories in src
.// src/* - list directories and files in src
.// *.txt - list files in current directory with .txt extension
.// {t*[1-3].txt} - list files in current directory with t*1.txt or t*2.txt or t*3.txt name
(on a case-insensitive filesystem this would also match T*1.txt etc)
.// {[T]*[1-3].txt} - list files in current directory with [T]*[1-3].txt name
(glob chars treated as literals due to being in character-class brackets
This will match files beginning with a capital T and not lower case t
even on a case-insensitive filesystem.)
.// {{[t],d{e,d}}*} - list directories and files in current directory with names that match either of the following patterns:
{[t]*} - names beginning with t
{d{e,d}*} - names beginning with de or dd
(on a case-insensitive filesystem the first pattern would also match names beginning with T)
}
@values -min 1 -max -1 -type string
v -type string -choices {/ //} -help\
"
/ - list directories only
// - list directories and files
"
fileglob_or_target -type string -optional true -multiple true -help\
"A glob pattern as supported by Tcl's 'glob' command, to filter results.
If multiple patterns are supplied, then a listing for each pattern is returned.
If no patterns are supplied, then all items are listed."
}
#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/ {v 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 {$v eq "/"} {
#directory only listing - we can optimize this by not getting file sizes and times - as these are only used for file listings
#we can't completely skip iterating over files as we want to know if there are any files in the directory - as this affects the display of links/shortcuts that point to directories - but we can skip getting sizes and times for files.
#todo?
}
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 b c p s} -with_sizes {f d l b c p s}]
} else {
if {[pwd] ne $VIRTUAL_CWD} {
commandstack::basecall cd $VIRTUAL_CWD
}
set matchinfo [dirfiles_dict -searchbase [pwd] -with_times {f d l b c p s} -with_sizes {f d l b c p s}]
}
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 resultsummary [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 resultsummary 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 $resultsummary 1 end]}
}
}
if {[string match //zipfs:/* $location]} {
set stripbase 0
} else {
set stripbase 1
}
#we need to pass matchinfo that includes files even when only doing a directory listing (d/ /)
#This is because we want to display links/shortcuts that point to directories as directories.
#( ./ listing needs to show navigable items)
#if {$v eq "/"} {
# #dodgy hack that doesn't give proper display of all links/shortcuts that are pointing to directories.
# dict set matchinfo files {}
# dict set matchinfo filesizes {}
#}
set out [dirfiles_dict_as_lines -listing $v -stripbase $stripbase $matchinfo]
#set chunklist [list]
#lappend chunklist [list stdout "[punk::ansi::a+ brightwhite]$out[punk::ansi::a]\n"]
set result "[punk::ansi::a+ brightwhite]$out[punk::ansi::a]\n"
append result $resultsummary
if {[file normalize $VIRTUAL_CWD] ne [pwd]} {
#lappend chunklist [list stderr "[punk::ansi::a+ red]PWD:[pwd] VIRTUAL_CWD:$VIRTUAL_CWD[punk::ansi::a]"]
puts 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 {
if {[llength $args] == 1} {
set cdtarget [lindex $args 0]
switch -exact -- $cdtarget {
. - ./ {
tailcall punk::nav::fs::d/ $v
}
.. - ../ {
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/ $v
}
#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 $cdtarget]
}
tailcall punk::nav::fs::d/ $v
}
}
set cdtarget_copy [punk::nav::fs::system::valcopy $cdtarget]
set cdtarget_copy [string map {\\ /} $cdtarget_copy]
if {[string range $cdtarget_copy 0 3] eq "//?/"} {
#handle dos device paths - convert to normal path for glob testing
set glob_test [string range $cdtarget_copy 3 end]
set cdtarget_is_glob [punk::nav::fs::lib::is_fileglob $glob_test]
} else {
set cdtarget_is_glob [punk::nav::fs::lib::is_fileglob $cdtarget]
#todo - review - we should be able to handle globs in dos device paths too - but we need to be careful to only test the glob chars in the part after the //?/ prefix - as the prefix itself contains chars that would be treated as globs if we tested the whole thing.
}
if {!$cdtarget_is_glob} {
set cdtarget_file_type [file type $cdtarget]
#e.g may be a link - whilst the type returned in the 'file stat' info reflects the type of the link target
} else {
set cdtarget_file_type "glob"
}
if {!$cdtarget_is_glob && [file pathtype $cdtarget] ne "relative"} {
#non-relative non-glob
if {![string match //zipfs:/* $cdtarget]} {
switch -- $cdtarget_file_type {
link {
file stat $cdtarget cdtargetinfo
set linktarget_file_type $cdtargetinfo(type)
if {$linktarget_file_type eq "directory"} {
set linktarget [file readlink $cdtarget]
cd $linktarget
#set VIRTUAL_CWD $cdtarget
tailcall punk::nav::fs::d/ $v
}
}
directory {
cd $cdtarget
#set VIRTUAL_CWD $cdtarget
tailcall punk::nav::fs::d/ $v
}
}
}
}
if {!$cdtarget_is_glob && ![string match //zipfs:/* $cdtarget] && ![string match "//zipfs:/*" $VIRTUAL_CWD]} {
switch -- $cdtarget_file_type {
link {
file stat $cdtarget cdtargetinfo
set linktarget_file_type $cdtargetinfo(type)
set linktarget [file readlink $cdtarget]
if {$linktarget_file_type eq "directory"} {
cd $linktarget
#set VIRTUAL_CWD $cdtarget
tailcall punk::nav::fs::d/ $v
}
}
directory {
cd $cdtarget
#set VIRTUAL_CWD $cdtarget
tailcall punk::nav::fs::d/ $v
}
}
#if {[file type $cdtarget] eq "directory"} {
# cd $cdtarget
# #set VIRTUAL_CWD [file normalize $cdtarget]
# tailcall punk::nav::fs::d/ $v
#}
}
if {!$cdtarget_is_glob} {
#NON-Glob target
#review
if {[string match //zipfs:/* $cdtarget]} {
if {[Zipfs_path_within_zipfs_mounts $cdtarget]} {
commandstack::basecall cd $cdtarget
}
set VIRTUAL_CWD $cdtarget
set curdir $cdtarget
tailcall punk::nav::fs::d/ $v
} else {
set target [punk::path::normjoin $VIRTUAL_CWD $cdtarget]
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/ $v
}
}
}
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 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)]
#we need to support the same glob chars that Tcl's 'glob' command accepts.
set has_tailglob [punk::nav::fs::lib::is_fileglob [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 -listing $v -stripbase $stripbase $matchinfo]
#lappend chunklist [list stdout "[punk::ansi::a+ brightwhite]$out[punk::ansi::a]\n"]
if {$result ne ""} {
append result \n
}
append result "[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]"]
puts 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 -listing / -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
}
#----------------------------------------------------
punk::args::define {
@id -id ::punk::nav::fs::newdir
@cmd -name punk::nav::fs::newdir\
-summary\
"Create directory or directories at the specified path(s)."\
-help\
"This command creates directories at the specified path(s).
If any part of the specified path does not exist, then it will be created as well.
If a specified path already exists, then it will be left as-is and no error will be raised.
A summary line is returned for each created directory, with the full path of the created
directory and a status line indicating the number of dirs and files in the directory if
it already existed (or showing 0 for both if it was just created)."
-nonportable -type none\
-help\
"Allows creation of directories which may not be portable across platforms.
Use with caution and only when you know what you are doing.
This allows creation of directories with names that may be invalid on some
platforms, or that may have special meanings on some platforms
(e.g reserved device names on windows).
If -nonportable is not supplied, then an error will be raised if any supplied
path is non-portable as defined by punk::winpath::illegalname_test.
Regardless of whether -nonportable is supplied or not, some characters are not
suitable for windows or most other platforms and will be rejected with an error.
An example of this is the null character (\0)."
@values -min 1 -max -1 -type string
path -type string -multiple 1 -help\
"Path(s) to create. Can be absolute or relative.
If any path is rejected due to -nonportable or other invalid characters,
or because a parent directory is not writable, then no directories will be created.
If a path already exists, then it will be left as-is and no error will be raised.
If despite passing the name tests or writability tests, a directory cannot be
created for some reason (e.g other filesystem error) then an error will be raised
and processing of any remaining paths will be aborted."
}
#todo - synchronize overall behaviour of newdir with that of newns (for namespaces)
proc newdir {args} {
set argd [punk::args::parse $args withid ::punk::nav::fs::newdir]
lassign [dict values $argd] leaders opts values received
set paths [dict get $values path]
set allow_nonportable [dict exists $received -nonportable]
set curdir [pwd]
set fullpath_list [list] ;#list of full paths to create.
set existing_parent_list [list] ;#list of nearest existing parent for each supplied path (used for writability testing, and as cd point from which to run file mkdir)
#these 2 lists are built up in parallel and should have the same number of items as the supplied paths that pass the initial tests.
set error_paths [list]
foreach p $paths {
if {!$allow_nonportable && [punk::winpath::illegalname_test $p]} {
#error "punk::nav::fs::newdir Path '$p' is not portable and may not be created without -nonportable option"
lappend error_paths [list $p "Path '$p' is not portable and may not be created without -nonportable option"]
continue
}
if {[string first \0 $p] != -1} {
#error "punk::nav::fs::newdir Path '$p' contains null character which is not allowed"
lappend error_paths [list $p "Path '$p' contains null character which is not allowed"]
continue
}
set fullpath [path_to_absolute $p $curdir $::tcl_platform(platform)]
#if we called punk::winpath::illegalname_fix on this, it could return something like //?/C:/test/illegalpath. dos device paths don't seem to be valid paths for file mkdir.
#Some subpaths of the supplied paths to create may already exist.
#we should test write permissions on the nearest existing parent of the supplied path to create,
#rather than just on the immediate parent segment of the supplied path itself which may not exist.
set fullpath [file normalize $fullpath]
set parent [file dirname $fullpath]
while {![file exists $parent]} {
set parent [file dirname $parent]
}
if {![file writable $parent]} {
#error "punk::nav::fs::newdir Cannot create directory '$fullpath' as parent '$parent' is not writable"
lappend error_paths [list $fullpath "Cannot create directory '$fullpath' as parent '$parent' is not writable"]
continue
}
lappend existing_parent_list $parent
lappend fullpath_list $fullpath
}
if {[llength $fullpath_list] != [llength $paths]} {
set path_error_display ""
foreach e $error_paths {
set p [lindex $e 0]
set m [lindex $e 1]
append path_error_display " Path: '$p' Error: $m\n"
}
error "punk::nav::fs::newdir One or more supplied paths were invalid or not writable:\n$path_error_display"
}
set num_created 0
set error_string ""
foreach fullpath $fullpath_list existing_parent $existing_parent_list {
#calculate relative path from existing parent to fullpath, and cd to existing parent before running file mkdir - to allow creation of directories with non-portable names on windows (e.g reserved device names) by using their relative paths from the nearest existing parent directory, which should be able to be cd'd into without issue.
#set relative_path [file relative $fullpath $existing_parent]
#todo.
if {[catch {file mkdir $fullpath}]} {
set error_string "Failed to create directory '$fullpath' - processing of remaining paths aborted."
cd $curdir
break
}
incr num_created
}
if {$error_string ne ""} {
error "punk::nav::fs::newdir $error_string\n$num_created directories out of [llength $fullpath_list] were created successfully before the error was encountered."
}
#display summaries of created directories (which may have already existed) by reusing d/ to get info on them.
set query_paths [lmap v $paths {string cat $v "/*"}]
d/ / {*}$query_paths
}
#----------------------------------------------------
punk::args::define {
@id -id ::punk::nav::fs::lib::gohome
@cmd -name punk::nav::fs::lib::gohome\
-summary\
"Navigate to a path relative to the current user's home directory."\
-help\
"Navigate to a path relative to the user's home directory.
This may usually correspond to the HOME environment variable, but some
tools may have pointed HOME elsewhere, so the home directory is determined
based on the current user as determined using the whoami command, which is
almost universally available on platforms that Tcl runs on, and should be
unaffected by any changes to environment variables.
This is a convenience function for quickly navigating to commonly used
locations within the home directory, without having to type out the full
path or use environment variables.
Like the './' command, this navigates to the folder and then lists the sub-directories,
with a summary of the number of sub-directories and files, and total file size in bytes.
"
@values -min 1 -max -1
path -type string -optional 1 -multiple 1 -help\
"Path relative to home directory to navigate to.
If the path does not exist, or is not a directory, then an error will be raised.
Examples:
gohome - will navigate to $HOME
(equivalent: gohome .)
gohome subdir1/subdir2 - will navigate to $HOME/subdir1/subdir2
(equivalent: gohome subdir1 subdir2)
gohome subdir1 - will navigate to $HOME/subdir1
An absolute path is also accepted, but then the navigation is not relative to the home
directory and is effectively just a normal navigation to the specified path.
(equivalent to using ./ <path>)
"
}
proc gohome {args} {
set home [punk::nav::fs::~]
set target [file join $home {*}$args]
if {![file isdirectory $target]} {
error "Folder $target not found"
}
d/ / $target
}
#run a file
#review. On unix the shebang should be able to choose the interpreter.
#on windows the ::env(PATHEXT) and file associations should be able to choose the interpreter. (see punk::auto_execok_better)
#when running using ./script_or_exe.name - the windows file association should be used.
#when running using x/ script_or_exe.name - we want to be able to run scripts even if no file association exists (or it is inappropriate for execution e.g ps1 defaults to open in editor)
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"]]\
ps1 [list exe pwsh extensions [list ".ps1"]]\
]
#todo - allow cofnig to specify arguments for the executable. eg pwsh -noprofile -executionpolicy remotesigned for running powershell scripts.
#this is a bit of a hack - fix
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 pwsh_extensions [list ".ps1"]
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 $script_extensions} {
set exename [dict get $scriptconfig $scriptlang exe]
set cmd [auto_execok $exename]
tailcall {*}$cmd $args
} else {
#review
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 {
if {$scriptfile eq ""} {
puts stderr "script not found"
} else {
puts stderr "No script executable known for files with extension [file extension $scriptfile]. Ensure file has a known extension ($script_extensions) or add a commented hint in the file such as #!/usr/bin/env tclsh"
}
}
}
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
punk::args::define {
@id -id ::punk::nav::fs::dirfiles
-stripbase -default 1 -type boolean
-formatsizes -default 1 -type boolean -help "Format file size numbers for clarity"
@values -min 0 -max -1 -unnamed true
}
proc dirfiles {args} {
set argd [punk::args::parse $args withid ::punk::nav::fs::dirfiles]
lassign [dict values $argd] leaders 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]]
set has_tailglobs [punk::nav::fs::lib::is_fileglob [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 -listing // -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
punk::args::define {
@id -id ::punk::nav::fs::dirfiles_dict
@cmd -name punk::nav::fs::dirfiles_dict\
-summary\
""\
-help\
"This command performs a directory listing of the specified location and returns the results as a dictionary
containing lists of keys such as files and directories and their properties.
The results are returned as a dictionary with the following structure:
{
location <searched location>
searchbase <searchbase supplied>
dirs {<list of directories matching search>}
vfsmounts {<list of entries that are mount points for virtual filesystems>}
links {<list of links matching search>}
linkinfo {<list of link targets for links matching search, in same order as links list, or 'na'>}
files {<list of files matching search>}
filesizes {<list of file sizes for files matching search, in same order as files list, or 'na'>}
sizes {<dictionary keyed on entry name with sub-dictionary of size information keyed with bytes>}
times {<dictionary keyed on entry name with sub-dictionary of time properties keyed with c a m>}
flaggedhidden {<dictionary keyed on entry name with value of 1 if entry is hidden or 0, for entries matching search, or 'na'>}
flaggedsystem {<dictionary keyed on entry name with value of 1 if entry is a system file or 0, for entries matching search, or 'na'>}
flaggedreadonly {<dictionary keyed on entry name with value of 1 if entry is read-only or 0, for entries matching search, or 'na'>}
altnames {<dictionary keyed on entry name with value of list of alternate names for that entry, or 'na'>}
opts {
-glob <glob pattern used for search>
-filedebug <filedebug supplied>
-patterndebug <patterndebug supplied>
-types <types supplied>
-with_sizes <with_sizes supplied>
-with_times <with_times supplied>
}
debuginfo {
<any debug info that may be useful to caller>
}
errors {
<any errors encountered during search, e.g inaccessible folders etc>
}
nonportable {<dictionary keyed on entry name with value of 1 if entry is non-portable or 0>}
underlayfiles {<list of files that are underlay files for virtual filesystem mounts matching search>}
underlayfilesizes {<list of sizes for underlay files for virtual filesystem mounts matching search, in same order as underlayfiles list, or 'na'>}
timinginfo {
<any timing info that may be useful to caller>
}
}
"
@opts -any 0
-searchbase -default ""
-tailglob -default "\uFFFF"
-filedebug -default 0 -type boolean
-patterndebug -default 0 -type boolean
#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 list
-with_times -default "\uFFFF" -type list
-link_info -default 1 -type boolean -help "When links are included in results, also include resparseinfo if present."
-portabilitycheck -default 1 -type boolean -help\
"Perform portability checks on entry names and flag non-portable entries in results.
Non-portable entries are those that may not be portable across platforms, for example due
to containing characters that are illegal on some platforms, or reserved device names on windows.
When this option is enabled, entries that are determined to be non-portable will be listed under
the 'nonportable' key."
-types -default {} -type list\
-help "Restrict results to specified types.
This uses the same basic types and mechanism as the Tcl 'glob' command.
entry:
{f}iles {d}irs {l}inks {s}ockets {p}ipes {b}lock devices {c}haracter special devices
attributes:
hidden readonly
permissions:
r w x
Note that on windows, Tcl's glob command uses very basic heuristics to determine the permissions - it doesn't
actually check the ACLs.
For example - the test for executable permission is just whether the file has a known executable extension
and the test for readonly is just whether the file has the read-only attribute set.
On unix, the permissions are likely to be determined by checking the actual permissions of the file against
the current user's uid and groups.
When entry types are given, results matching any of those types will be returned.
When attributes or permissions are given, only results matching all of the specified attributes or permissions
will be returned.
The default (empty list) is to return all types and ignore attributes and permissions.
If just attributes or permissions are given without entry types, then the types will be filtered according to
the specified attributes or permissions but not according to the directory entry type
- so for example if just 'hidden' attribute is given, then both files and folders with the hidden attribute
will be returned.
(todo - macintosh specific type handling)
"
@values -min 0 -max -1 -type string -unnamed true
}
proc dirfiles_dict {args} {
set argd [punk::args::parse $args withid ::punk::nav::fs::dirfiles_dict]
lassign [dict values $argd] leaders opts values
set searchspecs [dict values $values]
#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 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]
set opt_link_info [dict get $opts -link_info]
set opt_types [dict get $opts -types]
set opt_filedebug [dict get $opts -filedebug]
set opt_patterndebug [dict get $opts -patterndebug]
set opt_portabilitycheck [dict get $opts -portabilitycheck]
# -- --- --- --- --- --- ---
set searchspec [lindex $searchspecs 0]
#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_relativesearchspec} {
#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 [punk::nav::fs::lib::is_fileglob [file tail $searchspec]]
#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 is_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 is_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]
}
set ts1 [clock clicks -milliseconds]
if {$is_in_vfs} {
set listing [punk::du::lib::du_dirlisting_tclvfs $location -glob $match_contents -filedebug $opt_filedebug -patterndebug $opt_patterndebug {*}$next_opt_with_sizes {*}$next_opt_with_times -types $opt_types]
} else {
set invfs ""
switch -glob -- $location {
//zipfs:/* {
if {[info commands ::tcl::zipfs::mount] ne ""} {
set invfs zipfs
}
}
//cookit:/* {
set invfs cookit
}
default {
#handle 'other/unknown' that mounts at a volume-like path //pseudovol:/
#(intentionally will not match a dos device path such as //?/c:/)
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?
#flag so we don't use twapi - hope generic can handle it (uses tcl glob)
set invfs pseudovol
} 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
}
}
}
switch -- $invfs {
zipfs {
#relative vs absolute? review - cwd valid for //zipfs:/ ??
set listing [punk::du::lib::du_dirlisting_zipfs $location -glob $match_contents -filedebug $opt_filedebug -patterndebug $opt_patterndebug {*}$next_opt_with_sizes {*}$next_opt_with_times -types $opt_types]
}
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 -filedebug $opt_filedebug -patterndebug $opt_patterndebug {*}$next_opt_with_sizes {*}$next_opt_with_times -types $opt_types]
}
pseudovol {
set listing [punk::du::lib::du_dirlisting_generic $location -glob $match_contents -filedebug $opt_filedebug -patterndube $opt_patterndebug {*}$next_opt_with_sizes {*}$next_opt_with_times -types $opt_types]
}
default {
#The default call to punk::du::dirlisting will use the most appropriate mechanism for the platform and path
#- e.g twapi for windows local paths (if twapi is available), tcl glob for unix etc
#- and will be able to handle vfs paths that are visible to the filesystem as well (e.g cookit)
#- but may not be able to handle some vfs paths that aren't visible as normal files/folders to the filesystem
#(e.g if the vfs doesn't report itself as a vfs in vfs::filesystem info)
set listing [punk::du::dirlisting $location -glob $match_contents -filedebug $opt_filedebug -patterndebug $opt_patterndebug {*}$next_opt_with_sizes {*}$next_opt_with_times -link_info $opt_link_info -types $opt_types]
}
}
}
set ts2 [clock clicks -milliseconds]
set ts_listing [expr {$ts2 - $ts1}]
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] ".*"]
#todo - fix! we want to match any file or folder with a leading dot
#- but we also want to preserve the full path in the flaggedhidden list - so we need to check the tail of each entry for leading dot, rather than just doing a glob match on the whole path.
lappend flaggedhidden {*}[tcl::prefix::all [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 ts1 [clock milliseconds]
set dirs [lsort -dictionary $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 -dictionary $files]
set sorted_filesizes [list]
} else {
set sortorder [lsort -indices -dictionary $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
set ts2 [clock milliseconds]
set ts_sorting [expr {$ts2 - $ts1}]
#-----------------------------------------------------------------------------------------
# -- ---
#jmn
set ts1 [clock milliseconds]
if {$opt_portabilitycheck} {
foreach nm [list {*}$dirs {*}$files] {
if {[punk::winpath::illegalname_test $nm]} {
lappend nonportable $nm
}
}
}
set ts2 [clock milliseconds]
set ts_nonportable_check [expr {$ts2 - $ts1}]
set timing_info [dict create nonportable_check ${ts_nonportable_check}ms sorting ${ts_sorting}ms listing ${ts_listing}ms]
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 timinginfo $timing_info]
return [dict merge $listing $updated]
}
#replacement for tcl's glob.
#we can document with punk::args - but we don't want the overhead of full option parsing for every glob call - so we'll just do the option parsing manually within the proc.
#todo - add alias for punk::args id ::punk::nav::fs::fglob to ::glob so documentation matches.
proc fglob_parse_test1 {args} {
#tcl's glob requires a -- when arguments in positions that could be an option begin with a dash.
#This means accounting for prefixes of valid options and determining if they accept a parameter (which is allowed to begin with a dash) or not.
#Any argument that is in a possible option position and begins with a dash but isn't a valid option (or the -- itself)
#should raise an error rather than being treated as a literal glob pattern.
set valid_options [list -directory -join -nocomplain -path -tails -types]
set solo_options [list -nocomplain -join -tails]
set eopts_reached 0
set options [dict create] ;#for solos we will set the value to 1, for options that take parameters we will set the value to the parameter
set patterns [list]
for {set i 0} {$i < [llength $args]} {incr i} {
set a [lindex $args $i]
if {[string match -* $a]} {
if {$a eq "--"} {
set eopts_reached 1
set patterns [lrange $args [expr {$i + 1}] end]
break
}
#before -- we need to check if arg is a valid option or not
set full_option_name [tcl::prefix::match -error "" $valid_options $a]
if {$full_option_name ne ""} {
if {$full_option_name ni $solo_options} {
#option takes a parameter - so next arg is parameter even if it looks like an option
incr i
if {$i < [llength $args]} {
set param [lindex $args $i]
dict set options $full_option_name $param
} else {
error "fglob: option \"$a\" requires a parameter but none found"
}
} else {
dict set options $full_option_name 1
}
} else {
error "fglob: bad option \"$a\": must be [join $valid_options ", "] or --"
}
} else {
set patterns [lrange $args $i end]
break
}
}
return [dict create options $options patterns $patterns]
}
proc fglob_parse_test {args} {
#tcl's glob requires a -- when arguments in positions that could be an option begin with a dash.
#This means accounting for prefixes of valid options and determining if they accept a parameter (which is allowed to begin with a dash) or not.
#Any argument that is in a possible option position and begins with a dash but isn't a valid option (or the -- itself)
#should raise an error rather than being treated as a literal glob pattern.
#set valid_options [list -directory -join -nocomplain -path -tails -types]
#set solo_options [list -nocomplain -join -tails]
set options [dict create] ;#for solos we will set the value to 1, for options that take parameters we will set the value to the parameter
set patterns [list]
set arglen [llength $args]
for {set i 0; set j 1; set a [lindex $args 0]} {$i < $arglen} {incr j; set a [lindex $args [incr i]]} {
if {![string match -* $a]} {
#encountered non-option-like argument. All subsequent arguments should be treated as patterns even if they look like options.
return [dict create options $options patterns [lrange $args $i end]]
}
if {$a eq "--"} {
return [dict create options $options patterns [lrange $args $j end]]
}
#flag-like argument before -- we need to check if arg is a valid option or not
set full_option_name [tcl::prefix::match {-directory -join -nocomplain -path -tails -types} $a]
switch -- $full_option_name {
-directory - -path - -types {
#option takes a parameter - so next arg is parameter even if it looks like an option
if {$j < $arglen} {
dict set options $full_option_name [lindex $args $j]
incr i
incr j
} else {
error "fglob: option \"$a\" requires a parameter but none found"
}
}
default {
dict set options $full_option_name 1
}
}
}
return [dict create options $options patterns $patterns]
}
proc fglob {args} {
#tcl's glob requires a -- when arguments in positions that could be an option begin with a dash.
#This means accounting for prefixes of valid options and determining if they accept a parameter (which is allowed to begin with a dash) or not.
#Any argument that is in a possible option position and begins with a dash but isn't a valid option (or the -- itself)
#should raise an error rather than being treated as a literal glob pattern.
set valid_options [list -patterndebug -directory -join -nocomplain -path -tails -types]
#set solo_options [list -nocomplain -join -tails]
set options [dict create] ;#for solos we will set the value to 1, for options that take parameters we will set the value to the parameter
set patterns [list]
set arglen [llength $args]
for {set i 0; set j 1; set a [lindex $args 0]} {$i < $arglen} {incr j; set a [lindex $args [incr i]]} {
if {![string match -* $a]} {
#encountered non-option-like argument. All subsequent arguments should be treated as patterns even if they look like options.
#return [dict create options $options patterns [lrange $args $i end]]
set patterns [lrange $args $i end]
break
}
if {$a eq "--"} {
#return [dict create options $options patterns [lrange $args $j end]]
set patterns [lrange $args $j end]
break
}
#flag-like argument before -- we need to check if arg is a valid option or not
set full_option_name [tcl::prefix::match {-patterndebug -directory -join -nocomplain -path -tails -types} $a]
switch -- $full_option_name {
-patterndebug - -directory - -path - -types {
#option takes a parameter - so next arg is parameter even if it looks like an option
if {$j < $arglen} {
dict set options $full_option_name [lindex $args $j]
incr i
incr j
} else {
error "fglob: option \"$a\" requires a parameter but none found"
}
}
-join - -nocomplain - -tails {
dict set options $full_option_name 1
}
default {
error "fglob: bad option \"$a\": must be a unique prefix of [join $valid_options ", "] or --"
}
}
}
#return [dict create options $options patterns $patterns]
#todo -join
# process each glob as a directory listing.
if {[dict exists $options -directory]} {
set basedir [dict get $options -directory]
} else {
set basedir ""
}
#ignore -nocomplain - like tcl9 glob - if no results - return empty list rather than error
if {[dict exists $options -types]} {
set types [dict get $options -types]
} else {
set types {}
}
if {[dict exists $options -patterndebug]} {
set opt_patterndebug [dict get $options -patterndebug]
} else {
set opt_patterndebug 0
}
#todo - fix for multiple absolute paths supplied.
#e.g c:/cmdfiles/*.exe c:/repo/jn/shellspy/bin/*.exe
#- we would want to treat as two separate globs with different basedirs
#for common basedir - we might be better off creating a single glob pattern using the brace syntax for alternatives.
#TCL's glob returns a single list when multiple patterns supplied.
#It does not seem to sort or de-dup, or group results by type.
set results [list]
foreach pattern $patterns {
set resultd [dirfiles_dict -patterndebug $opt_patterndebug -portabilitycheck 0 -searchbase $basedir -with_times 0 -with_sizes 0 -link_info 0 -types $types -tailglob $pattern]
#puts [showdict $resultd]
#todo - other types?
lappend results {*}[dict get $resultd dirs] {*}[dict get $resultd files] {*}[dict get $resultd links]
}
return $results
}
punk::args::define {
@id -id ::punk::nav::fs::dirfiles_dict_as_lines
-stripbase -default 0 -type boolean
-formatsizes -default 1 -type boolean
-listing -default "/" -choices {/ //}
@values -min 1 -max -1 -type dict -unnamed true
}
#todo - color key via repl-telemetry? help command? documentation? or add tag columns as done in namespace listing?
proc dirfiles_dict_as_lines {args} {
#set ts1 [clock milliseconds]
package require overtype
set argd [punk::args::parse $args withid ::punk::nav::fs::dirfiles_dict_as_lines]
lassign [dict values $argd] leaders opts vals
set list_of_dicts [dict values $vals]
# -- --- --- --- --- --- --- --- --- --- --- ---
set opt_stripbase [dict get $opts -stripbase]
set opt_formatsizes [dict get $opts -formatsizes]
set opt_listing [dict get $opts -listing]
# -- --- --- --- --- --- --- --- --- --- --- ---
#we still need to examine files for -listing / which means show only directories,
# because we want to display links/shortcuts that point to directories as directories
#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
# - note also that case-insensitivity can be configured per folder on windows via the fsutil.exe utility
# unfortunately we have no simple & fast way to query the case-sensitivity of a particular folder or filesystem.
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 base_relative_path [strip_prefix_depth $fullname $common_base]
dict set fkeys $base_relative_path $fullname ;#cache so we can retrieve already normalised name without re-hitting filesystem
lappend stripped $base_relative_path
}
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
set file_shortcuts [list] ;#windows shell links (.lnk) that have a target that is a file
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 ""
if {$f in $file_symlinks} {
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 $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
#review
#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]
#set ts2 [clock milliseconds]
foreach fdict $finfo {
set fname [dict get $fdict file]
if {[file extension $fname] eq ".lnk"} {
if {![catch {package require punk::winlnk}]} {
set target_type "file" ;#default/fallback
set shortcutinfo [punk::winlnk::resolve $fname] ;#will always return a dict. Will only contain error key if there was an error.
if {[dict exists $shortcutinfo link_roottarget]} {
set is_valid_lnk 1
set root_tgt [dict get $shortcutinfo link_roottarget]
set link_target_type [dict get $shortcutinfo target_type]
switch -- $link_target_type {
file {
set target_type "file"
}
directory - "local disk" {
set target_type "directory"
}
unknown {
#fall back to checking attributes and filesystem if we have a link_roottarget but no target_type
if {[file exists $root_tgt]} {
#file type could return 'link' - we will use isfile/isdirectory
if {[file isfile $root_tgt]} {
set target_type file
} elseif {[file isdirectory $root_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_roottarget - 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]
if {[dict exists $shortcutinfo stringdata command_line_arguments]} {
set display "$fshortcut_style$display (shortcut to $root_tgt [dict get $shortcutinfo stringdata command_line_arguments])"
} else {
set display "$fshortcut_style$display (shortcut $root_tgt)" ;#
}
dict set fdict display $display
lappend finfo_plus $fdict
lappend file_shortcuts $fname
}
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
#review: we shouldn't see a link to a dir that also has command_line_arguments
#- but if we do, we will just ignore the command_line_arguments for now and treat as a directory shortcut.
lappend dirs $fname
lappend dir_shortcuts $fname
}
}
} else {
#we were unable to get link_roottarget - 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_roottarget
#report and move on
puts stderr "Unexpected error in result of parsing binary format for $fname."
puts stderr "Result was [showdict $shortcutinfo]"
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
#puts stderr "dirfiles_dict_as_lines since ts2 [clock milliseconds] - $ts2 ms = [expr {[clock milliseconds] - $ts2}]"
#puts stderr "dirfiles_dict_as_lines since start [clock milliseconds] - $ts1 ms = [expr {[clock milliseconds] - $ts1}]"
#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]
if {$opt_listing eq "/"} {
#disply directories only (including items that were actually files that were links/shortcuts to directories)
set finfo_plus [list]
}
foreach d $dirs filerec $finfo_plus {
set d1 [punk::ansi::a+ cyan normal]
set d1_overrides [list]
#set d2 [punk::ansi::a+ defaultfg defaultbg normal]
set f1 [punk::ansi::a+ white normal]
set f1_overrides [list]
#set f2 [punk::ansi::a+ defaultfg defaultbg normal]
set fdisp ""
if {[string length $d]} {
if {$d in $flaggedhidden} {
#set d1 [punk::ansi::a+ Term-grey50 normal]
lappend d1_overrides term-grey50
}
if {$d in $vfsmounts} {
lappend d1_overrides Green
}
if {$d in $nonportable} {
#lappend d1_overrides underline undt-red ;#we use underlins to indicate symlinks and shortcuts, so we shouldn't use underlines here if possible.
lappend d1_overrides italic bold
}
#dlink_style & dshortcut_style are for underlines - can be added with colours already set
if {[llength $d1_overrides]} {
set d1 [punk::ansi::a+ {*}$d1_overrides]
}
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+ Term-grey50]
lappend f1_overrides term-grey50
}
if {$fname in $nonportable} {
lappend f1_overrides italic bold
}
if {[llength $f1_overrides]} {
set f1 [punk::ansi::a+ {*}$f1_overrides]
}
if {$fname in $file_symlinks} {
append f1 $flink_style
}
#fshortcut_style already set in the display string for shortcuts targeting files, so we don't need to add it here.
lappend displaylist [overtype::left $col1 $d1$d$RST]$f1$fdisp$RST
} else {
#either there are no files or opt_listing is / = show dirs only (some of which may have actually been files that were links/shortcuts to directories)
lappend displaylist [overtype::left $col1 $d1$d$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 {subpath base platform} {
set ptype [file pathtype $subpath]
if {$ptype eq "absolute"} {
set path_absolute $subpath
} 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 $subpath 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 $subpath]
#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/$subpath
set path_absolute $subpath
}
} else {
# unknown what paths are reported as this on other platforms.. treat as absolute for now
set path_absolute $subpath
}
} else {
#e.g relative subpath=* base = c:/test -> c:/test/*
#e.g relative subpath=../test base = c:/test -> c:/test/../test
#e.g relative subpath=* base = //server/share/test -> //server/share/test/*
set path_absolute $base/$subpath
}
#fixing up paths on windows here violates the principle of single responsibility - this function is supposed to be about converting to absolute paths - not fixing up windows path issues.
#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]
punk::args::define {
@id -id ::punk::nav::fs::lib::is_fileglob
@cmd -name punk::nav::fs::lib::is_fileglob\
-help\
"Determine if a string is a glob pattern as recognised by the tcl 'glob' command.
This is used for example to determine whether to treat a path component as a literal
or a glob pattern when processing paths with glob patterns in them (e.g for the ./ command)."
@values -min 1 -max 1
path -type string -optional 0 -help\
{String to test for being a glob pattern as recognised by the tcl 'glob' command.
If the string represents a path with multiple segments, only the final component
of the path will be tested for glob characters.
Glob patterns in this context are different to globs accepted by TCL's 'string match'.
A glob pattern is any string that contains unescaped * ? { } [ or ].
This will not detect mismatched unescaped braces or brackets.
Such a sequence will be treated as a glob pattern, even though it may not be a valid glob pattern.
}
}
proc is_fileglob {str} {
#a glob pattern is any string that contains unescaped * ? { } [ or ] (we will ignore the possibility of ] being used without a matching [ as that is likely to be rare and would be difficult to detect without a full glob parser)
set in_escape 0
set segments [file split $str]
set tail [lindex $segments end]
foreach c [split $tail ""] {
if {$in_escape} {
set in_escape 0
} else {
if {$c eq "\\"} {
set in_escape 1
} elseif {$c in [list * ? "\[" "\]" "{" "}" ]} {
return 1
}
}
}
return 0
}
#*** !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
#utility function to copy values from one variable to another without sharing the reference.
#Useful for example to avoid some issues with possible shimmering of the underlying type of file paths.
proc valcopy {obj} {
append obj2 $obj {}
}
#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
}
}
interp alias {} ~ {} punk::nav::fs::~
interp alias {} ./ {} punk::nav::fs::d/ /
interp alias {} d/ {} punk::nav::fs::d/ /
interp alias {} .// {} punk::nav::fs::d/ //
interp alias {} d// {} punk::nav::fs::d/ //
interp alias {} ../ {} punk::nav::fs::dd/
interp alias {} dd/ {} punk::nav::fs::dd/
interp alias {} vwd {} punk::nav::fs::vwd ;#return punk::nav::fs::VIRTUAL_CWD - and report to stderr pwd if different
interp alias {} dirlist {} punk::nav::fs::dirlist
interp alias {} dirfiles {} punk::nav::fs::dirfiles
interp alias {} dirfiles_dict {} punk::nav::fs::dirfiles_dict
interp alias {} fglob {} punk::nav::fs::fglob
interp alias {} newdir {} punk::nav::fs::newdir
#this also conflicts with auto_cd as there could be a local folder (or file) called ~.
interp alias {} gohome {} punk::nav::fs::gohome
#review
interp alias {} x/ {} punk::nav::fs::x/
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::nav::fs [tcl::namespace::eval punk::nav::fs {
variable pkg punk::nav::fs
variable version
set version 0.1.0
}]
return
#*** !doctools
#[manpage_end]