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