"Allow 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 d/new with that of n/new (for namespaces)
proc d/new {args} {
if {![llength $args]} {
error "usage: d/new <dir> \[<dir> ...\]"
}
set a1 [lindex $args 0]
set argd [punk::args::parse $args withid ::punk::nav::fs::d/new]
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]
set error_paths [list]
foreach p $paths {
if {!$allow_nonportable && [punk::winpath::illegalname_test $p]} {
#error "punk::nav::fs::d/new 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::d/new 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 path1 [path_to_absolute $a1 $curdir $::tcl_platform(platform)]
#e.g can return something like //?/C:/test/illegalpath. which is not a valid path for mkdir.
set fullpath [file join $path1 {*}[lrange $args 1 end]]
if {[file exists $fullpath]} {
error "Folder $fullpath already exists"
#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 supplied path itself which may not exist at all.
set parent [file dirname $fullpath]
while {![file exists $parent]} {
set parent [file dirname $parent]
}
if {![file writable $parent]} {
#error "punk::nav::fs::d/new 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 fullpath_list $fullpath
}
if {[llength $fullpath_list] != [llength $paths]} {
error "punk::nav::fs::d/new 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 {
if {[catch {file mkdir $fullpath}]} {
set error_string "Failed to create directory '$fullpath' - processing of remaining paths aborted."
break
}
incr num_created
}
file mkdir $fullpath
d/ $fullpath
if {$error_string ne ""} {
error "punk::nav::fs::d/new $error_string\n$num_created directories out of [llength $fullpath_list] were created successfully before the error was encountered."
#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.
set is_in_vfs 0 ;#we use this only for a vfs which is reported to have a mountpoint by vfs::filesystem info - not all that have -vfs 1 attr like cookit.
if {[llength [package provide vfs]]} {
foreach mount [vfs::filesystem info] {
if {[punk::mix::base::lib::path_a_atorbelow_b $location $mount]} {
#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]
}
lappend d1_overrides Green
}
} else {
if {$d in $nonportable} {
set d1 [punk::ansi::a+ red bold]
}
}
#lappend d1_overrides underline undt-red ;#we use underlins to indicate symlinks and shortcuts, so we shouldn't use underlines here if possible.
lappend d1_overrides italic bold
}
#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 indication 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
#according to the above: Use any character in the current code page for a name, including Unicode characters and characters in the extended character set (128–255), except for the following:
set reserved [list < > : \" / \\ | ? *]
#embedded nulls (\0) are also disallowed - but these are also disallowed on unix-like platforms.
if {[string toupper [file rootname $seg]] in $windows_reserved_names} {
#windows reserved names
#there are reports that these names aren't usable even with file extension - e.g that CON.txt is reserved and can't be created by some standard tools.
#In practice on windows 11 in 2026, cmd.exe,notepad,explorer and powershell seem to handle creation and access of CON.txt and PRN.txt etc without issue.
# the windows documentation reference above however still states that these names with an extension should be avoided.
#For this reason - we will still treat these as reserved and require protection with dos device syntax - even though in practice they seem to be usable without it.
return 1
}
#only check for actual space as other whitespace seems to work without being stripped
#trailing tab and trailing \n or \r seem to be creatable in windows with Tcl - map to some glyph
"Allow 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 d/new with that of n/new (for namespaces)
proc d/new {args} {
if {![llength $args]} {
error "usage: d/new <dir> \[<dir> ...\]"
}
set a1 [lindex $args 0]
set argd [punk::args::parse $args withid ::punk::nav::fs::d/new]
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]
set error_paths [list]
foreach p $paths {
if {!$allow_nonportable && [punk::winpath::illegalname_test $p]} {
#error "punk::nav::fs::d/new 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::d/new 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 path1 [path_to_absolute $a1 $curdir $::tcl_platform(platform)]
#e.g can return something like //?/C:/test/illegalpath. which is not a valid path for mkdir.
set fullpath [file join $path1 {*}[lrange $args 1 end]]
if {[file exists $fullpath]} {
error "Folder $fullpath already exists"
#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 supplied path itself which may not exist at all.
set parent [file dirname $fullpath]
while {![file exists $parent]} {
set parent [file dirname $parent]
}
if {![file writable $parent]} {
#error "punk::nav::fs::d/new 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 fullpath_list $fullpath
}
if {[llength $fullpath_list] != [llength $paths]} {
error "punk::nav::fs::d/new 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 {
if {[catch {file mkdir $fullpath}]} {
set error_string "Failed to create directory '$fullpath' - processing of remaining paths aborted."
break
}
incr num_created
}
file mkdir $fullpath
d/ $fullpath
if {$error_string ne ""} {
error "punk::nav::fs::d/new $error_string\n$num_created directories out of [llength $fullpath_list] were created successfully before the error was encountered."
#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.
set is_in_vfs 0 ;#we use this only for a vfs which is reported to have a mountpoint by vfs::filesystem info - not all that have -vfs 1 attr like cookit.
if {[llength [package provide vfs]]} {
foreach mount [vfs::filesystem info] {
if {[punk::mix::base::lib::path_a_atorbelow_b $location $mount]} {
#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]
}
lappend d1_overrides Green
}
} else {
if {$d in $nonportable} {
set d1 [punk::ansi::a+ red bold]
}
}
#lappend d1_overrides underline undt-red ;#we use underlins to indicate symlinks and shortcuts, so we shouldn't use underlines here if possible.
lappend d1_overrides italic bold
}
#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 indication 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
set idlist_size [Get_LinkTargetIDList_size $contents]
if {$idlist_size == 0} {
return ""
} else {
set idlist_content [string range $contents 78 [expr {78 + $idlist_size -1}]]
return $idlist_content
}
}
#some clues on the structure of the IDList content and how to parse it can be found in the analysis of CVE-2020-0729,
#which is a remote code execution vulnerability in Windows that can be exploited through specially crafted .lnk files that contain malicious IDList content.
#The analysis of this vulnerability provides insights into how the IDList content is structured and how it can be parsed to extract information about the link target and potentially execute code.
set linkinfocontent [dict get $linkinfo_content_dict content]
set next_start [dict get $linkinfo_content_dict next_start] ;#location of section following LinkInfo (Location information) - this will be the Data Strings.
set link_target ""
set linkfields [dict create]
if {$linkinfocontent ne ""} {
set linkfields [LinkInfo_get_fields $linkinfocontent]
set localbase_path [dict get $linkfields localbasepath]
#according to the above: Use any character in the current code page for a name, including Unicode characters and characters in the extended character set (128–255), except for the following:
set reserved [list < > : \" / \\ | ? *]
#embedded nulls (\0) are also disallowed - but these are also disallowed on unix-like platforms.
if {[string toupper [file rootname $seg]] in $windows_reserved_names} {
#windows reserved names
#there are reports that these names aren't usable even with file extension - e.g that CON.txt is reserved and can't be created by some standard tools.
#In practice on windows 11 in 2026, cmd.exe,notepad,explorer and powershell seem to handle creation and access of CON.txt and PRN.txt etc without issue.
# the windows documentation reference above however still states that these names with an extension should be avoided.
#For this reason - we will still treat these as reserved and require protection with dos device syntax - even though in practice they seem to be usable without it.
return 1
}
#only check for actual space as other whitespace seems to work without being stripped
#trailing tab and trailing \n or \r seem to be creatable in windows with Tcl - map to some glyph
"Allow 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 d/new with that of n/new (for namespaces)
proc d/new {args} {
if {![llength $args]} {
error "usage: d/new <dir> \[<dir> ...\]"
}
set a1 [lindex $args 0]
set argd [punk::args::parse $args withid ::punk::nav::fs::d/new]
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]
set error_paths [list]
foreach p $paths {
if {!$allow_nonportable && [punk::winpath::illegalname_test $p]} {
#error "punk::nav::fs::d/new 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::d/new 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 path1 [path_to_absolute $a1 $curdir $::tcl_platform(platform)]
#e.g can return something like //?/C:/test/illegalpath. which is not a valid path for mkdir.
set fullpath [file join $path1 {*}[lrange $args 1 end]]
if {[file exists $fullpath]} {
error "Folder $fullpath already exists"
#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 supplied path itself which may not exist at all.
set parent [file dirname $fullpath]
while {![file exists $parent]} {
set parent [file dirname $parent]
}
if {![file writable $parent]} {
#error "punk::nav::fs::d/new 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 fullpath_list $fullpath
}
if {[llength $fullpath_list] != [llength $paths]} {
error "punk::nav::fs::d/new 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 {
if {[catch {file mkdir $fullpath}]} {
set error_string "Failed to create directory '$fullpath' - processing of remaining paths aborted."
break
}
incr num_created
}
file mkdir $fullpath
d/ $fullpath
if {$error_string ne ""} {
error "punk::nav::fs::d/new $error_string\n$num_created directories out of [llength $fullpath_list] were created successfully before the error was encountered."
#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.
set is_in_vfs 0 ;#we use this only for a vfs which is reported to have a mountpoint by vfs::filesystem info - not all that have -vfs 1 attr like cookit.
if {[llength [package provide vfs]]} {
foreach mount [vfs::filesystem info] {
if {[punk::mix::base::lib::path_a_atorbelow_b $location $mount]} {
#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]
}
lappend d1_overrides Green
}
} else {
if {$d in $nonportable} {
set d1 [punk::ansi::a+ red bold]
}
}
#lappend d1_overrides underline undt-red ;#we use underlins to indicate symlinks and shortcuts, so we shouldn't use underlines here if possible.
lappend d1_overrides italic bold
}
#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 indication 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
#according to the above: Use any character in the current code page for a name, including Unicode characters and characters in the extended character set (128–255), except for the following:
set reserved [list < > : \" / \\ | ? *]
#embedded nulls (\0) are also disallowed - but these are also disallowed on unix-like platforms.
if {[string toupper [file rootname $seg]] in $windows_reserved_names} {
#windows reserved names
#there are reports that these names aren't usable even with file extension - e.g that CON.txt is reserved and can't be created by some standard tools.
#In practice on windows 11 in 2026, cmd.exe,notepad,explorer and powershell seem to handle creation and access of CON.txt and PRN.txt etc without issue.
# the windows documentation reference above however still states that these names with an extension should be avoided.
#For this reason - we will still treat these as reserved and require protection with dos device syntax - even though in practice they seem to be usable without it.
return 1
}
#only check for actual space as other whitespace seems to work without being stripped
#trailing tab and trailing \n or \r seem to be creatable in windows with Tcl - map to some glyph
"Allow 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 d/new with that of n/new (for namespaces)
proc d/new {args} {
if {![llength $args]} {
error "usage: d/new <dir> \[<dir> ...\]"
}
set a1 [lindex $args 0]
set argd [punk::args::parse $args withid ::punk::nav::fs::d/new]
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]
set error_paths [list]
foreach p $paths {
if {!$allow_nonportable && [punk::winpath::illegalname_test $p]} {
#error "punk::nav::fs::d/new 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::d/new 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 path1 [path_to_absolute $a1 $curdir $::tcl_platform(platform)]
#e.g can return something like //?/C:/test/illegalpath. which is not a valid path for mkdir.
set fullpath [file join $path1 {*}[lrange $args 1 end]]
if {[file exists $fullpath]} {
error "Folder $fullpath already exists"
#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 supplied path itself which may not exist at all.
set parent [file dirname $fullpath]
while {![file exists $parent]} {
set parent [file dirname $parent]
}
if {![file writable $parent]} {
#error "punk::nav::fs::d/new 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 fullpath_list $fullpath
}
if {[llength $fullpath_list] != [llength $paths]} {
error "punk::nav::fs::d/new 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 {
if {[catch {file mkdir $fullpath}]} {
set error_string "Failed to create directory '$fullpath' - processing of remaining paths aborted."
break
}
incr num_created
}
file mkdir $fullpath
d/ $fullpath
if {$error_string ne ""} {
error "punk::nav::fs::d/new $error_string\n$num_created directories out of [llength $fullpath_list] were created successfully before the error was encountered."
#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.
set is_in_vfs 0 ;#we use this only for a vfs which is reported to have a mountpoint by vfs::filesystem info - not all that have -vfs 1 attr like cookit.
if {[llength [package provide vfs]]} {
foreach mount [vfs::filesystem info] {
if {[punk::mix::base::lib::path_a_atorbelow_b $location $mount]} {
#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]
}
lappend d1_overrides Green
}
} else {
if {$d in $nonportable} {
set d1 [punk::ansi::a+ red bold]
}
}
#lappend d1_overrides underline undt-red ;#we use underlins to indicate symlinks and shortcuts, so we shouldn't use underlines here if possible.
lappend d1_overrides italic bold
}
#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 indication 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
#according to the above: Use any character in the current code page for a name, including Unicode characters and characters in the extended character set (128–255), except for the following:
set reserved [list < > : \" / \\ | ? *]
#embedded nulls (\0) are also disallowed - but these are also disallowed on unix-like platforms.
if {[string toupper [file rootname $seg]] in $windows_reserved_names} {
#windows reserved names
#there are reports that these names aren't usable even with file extension - e.g that CON.txt is reserved and can't be created by some standard tools.
#In practice on windows 11 in 2026, cmd.exe,notepad,explorer and powershell seem to handle creation and access of CON.txt and PRN.txt etc without issue.
# the windows documentation reference above however still states that these names with an extension should be avoided.
#For this reason - we will still treat these as reserved and require protection with dos device syntax - even though in practice they seem to be usable without it.
return 1
}
#only check for actual space as other whitespace seems to work without being stripped
#trailing tab and trailing \n or \r seem to be creatable in windows with Tcl - map to some glyph
"Allow 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 d/new with that of n/new (for namespaces)
proc d/new {args} {
if {![llength $args]} {
error "usage: d/new <dir> \[<dir> ...\]"
}
set a1 [lindex $args 0]
set argd [punk::args::parse $args withid ::punk::nav::fs::d/new]
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]
set error_paths [list]
foreach p $paths {
if {!$allow_nonportable && [punk::winpath::illegalname_test $p]} {
#error "punk::nav::fs::d/new 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::d/new 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 path1 [path_to_absolute $a1 $curdir $::tcl_platform(platform)]
#e.g can return something like //?/C:/test/illegalpath. which is not a valid path for mkdir.
set fullpath [file join $path1 {*}[lrange $args 1 end]]
if {[file exists $fullpath]} {
error "Folder $fullpath already exists"
#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 supplied path itself which may not exist at all.
set parent [file dirname $fullpath]
while {![file exists $parent]} {
set parent [file dirname $parent]
}
if {![file writable $parent]} {
#error "punk::nav::fs::d/new 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 fullpath_list $fullpath
}
if {[llength $fullpath_list] != [llength $paths]} {
error "punk::nav::fs::d/new 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 {
if {[catch {file mkdir $fullpath}]} {
set error_string "Failed to create directory '$fullpath' - processing of remaining paths aborted."
break
}
incr num_created
}
file mkdir $fullpath
d/ $fullpath
if {$error_string ne ""} {
error "punk::nav::fs::d/new $error_string\n$num_created directories out of [llength $fullpath_list] were created successfully before the error was encountered."
#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.
set is_in_vfs 0 ;#we use this only for a vfs which is reported to have a mountpoint by vfs::filesystem info - not all that have -vfs 1 attr like cookit.
if {[llength [package provide vfs]]} {
foreach mount [vfs::filesystem info] {
if {[punk::mix::base::lib::path_a_atorbelow_b $location $mount]} {
#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]
}
lappend d1_overrides Green
}
} else {
if {$d in $nonportable} {
set d1 [punk::ansi::a+ red bold]
}
}
#lappend d1_overrides underline undt-red ;#we use underlins to indicate symlinks and shortcuts, so we shouldn't use underlines here if possible.
lappend d1_overrides italic bold
}
#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 indication 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
#according to the above: Use any character in the current code page for a name, including Unicode characters and characters in the extended character set (128–255), except for the following:
set reserved [list < > : \" / \\ | ? *]
#embedded nulls (\0) are also disallowed - but these are also disallowed on unix-like platforms.
if {[string toupper [file rootname $seg]] in $windows_reserved_names} {
#windows reserved names
#there are reports that these names aren't usable even with file extension - e.g that CON.txt is reserved and can't be created by some standard tools.
#In practice on windows 11 in 2026, cmd.exe,notepad,explorer and powershell seem to handle creation and access of CON.txt and PRN.txt etc without issue.
# the windows documentation reference above however still states that these names with an extension should be avoided.
#For this reason - we will still treat these as reserved and require protection with dos device syntax - even though in practice they seem to be usable without it.
return 1
}
#only check for actual space as other whitespace seems to work without being stripped
#trailing tab and trailing \n or \r seem to be creatable in windows with Tcl - map to some glyph
