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
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 999999.0a1.0 |
|
# Meta platform tcl |
|
# Meta license <unspecified> |
|
# @@ Meta End |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# doctools header |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
#*** !doctools |
|
#[manpage_begin punkshell_module_punk::nav::fs 0 999999.0a1.0] |
|
#[copyright "2024"] |
|
#[titledesc {punk::nav::fs console filesystem navigation}] [comment {-- Name section and table of contents description --}] |
|
#[moddesc {fs nav}] [comment {-- Description at end of page heading --}] |
|
#[require punk::nav::fs] |
|
#[keywords module filesystem terminal] |
|
#[description] |
|
#[para] - |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[section Overview] |
|
#[para] overview of punk::nav::fs |
|
#[subsection Concepts] |
|
#[para] - |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Requirements |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[subsection dependencies] |
|
#[para] packages used by punk::nav::fs |
|
#[list_begin itemized] |
|
|
|
package require Tcl 8.6- |
|
package require punk::lib |
|
package require punk::args |
|
package require punk::ansi |
|
package require punk::winpath |
|
package require punk::du ;#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 999999.0a1.0 |
|
}] |
|
return |
|
|
|
#*** !doctools |
|
#[manpage_end] |
|
|
|
|