# -*- tcl -*- # Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -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 # @@ 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 ~' #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 ./ ) " } 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/ ?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 searchbase dirs {} vfsmounts {} links {} linkinfo {} files {} filesizes {} sizes {} times {} flaggedhidden {