You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
237 lines
10 KiB
237 lines
10 KiB
# -*- tcl -*- |
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
|
# |
|
# 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) 2023 |
|
# |
|
# @@ Meta Begin |
|
# Application punk::unixywindows 0.1.0 |
|
# Meta platform tcl |
|
# Meta license <unspecified> |
|
# @@ Meta End |
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Requirements |
|
##e.g package require frobz |
|
|
|
#for illegalname_test |
|
package require punk::winpath |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
namespace eval punk::unixywindows { |
|
#'cached' name to make obvious it could be out of date - and to distinguish from unixyroot arg |
|
variable cachedunixyroot "" |
|
|
|
|
|
#----------------- |
|
#e.g something like c:/Users/geek/scoop/apps/msys2/current c:/msys2 |
|
proc get_unixyroot {} { |
|
variable cachedunixyroot |
|
if {![string length $cachedunixyroot]} { |
|
if {![catch { |
|
set result [exec cygpath -m /] ;# -m gives result with forward-slashes - which is ok for windows paths in a Tcl context. |
|
set cachedunixyroot [punk::valcopy $result] |
|
file pathtype $cachedunixyroot; #this call causes the int-rep to be path |
|
#set ::punk::last_run_display [list] ;#hack - review shouldn't really be necessary.. but because we call winpath from ./ - the repl looks for last_run_display |
|
} errM]} { |
|
|
|
} else { |
|
puts stderr "Warning: Failed to determine base for unix-like paths - using default of c:/msys2" |
|
file pathtype [set cachedunixyroot [punk::valcopy "c:/msys2"]] |
|
} |
|
} |
|
#will have been shimmered from string to 'path' internal rep by 'file pathtype' call |
|
|
|
#let's return a different copy as it's so easy to lose path-rep |
|
set copy [punk::valcopy $cachedunixyroot] |
|
return $copy |
|
} |
|
proc refresh_unixyroot {} { |
|
variable cachedunixyroot |
|
set result [exec cygpath -m /] ;# -m gives result with forward-slashes - which is ok for windows paths in a Tcl context. |
|
set cachedunixyroot [punk::valcopy $result] |
|
file pathtype $cachedunixyroot; #this call causes the int-rep to be path |
|
|
|
set copy [punk::valcopy $cachedunixyroot] |
|
return $copy |
|
} |
|
proc set_unixyroot {windows_path} { |
|
variable cachedunixyroot |
|
file pathtype $windows_path |
|
set cachedunixyroot [punk::valcopy $windows_path] |
|
#return the original - but probably int-rep will have shimmered to path even if started out as string |
|
#- that's probably what we want. Caller can use as string or path without affecting cachedunixyroot |
|
return $windows_path |
|
} |
|
|
|
|
|
proc windir {path} { |
|
if {$path eq "~"} { |
|
#as the tilde hasn't been normalized.. we can't assume we're running on the actual platform |
|
return ~/.. |
|
} |
|
return [file dirname [towinpath $path]] |
|
} |
|
|
|
#REVIEW high-coupling |
|
proc cdwin {path} { |
|
set path [towinpath $path] |
|
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
|
if {[llength [info commands ::punk::console::titleset]]} { |
|
::punk::console::titleset $path |
|
} |
|
} |
|
cd $path |
|
} |
|
proc cdwindir {path} { |
|
set path [towinpath $path] |
|
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
|
if {[llength [info commands ::punk::console::titleset]]} { |
|
::punk::console::titleset $path |
|
} |
|
} |
|
cd [file dirname $path] |
|
} |
|
|
|
#NOTE - this is an expensive operation - avoid where possible. |
|
#review - is this intended to be useful/callable on non-windows platforms? |
|
#it should in theory be useable from another platform that wants to create a path for use on windows. |
|
#In this case - we shouldn't examine what volumes exist (assume A: .. Z: are valid) |
|
#review zipfs:// other uri schemes? |
|
proc towinpath {unixypath {unixyroot ""}} { |
|
#NOTE: tcl file exists gives different answers on windows for paths like /c depending on cwd (presumably based on file pathtype of volumerelative) |
|
#(Tcl is also somewhat broken as at 2023 as far as volume relative paths - process can get out of sync with tcl if cd to a vol relative path is used) |
|
#This is add odds with attempting to navigate on a windows system which has cygwin, wsl etc... It also makes it difficult for functions intended to operate independent of CWD. |
|
#e.g there is potential confusion when there is a c folder on c: drive (c:/c) |
|
#I will attempt to provide a coherent operation for winpath ./ ../ etc , but it may disallow for example; change to /something or /x where these don't match a driveletter or /mnt |
|
#whereas tcl may allow cd to /something if a something folder happens to exist on the current volume based on cwd. |
|
#I think it's preferable to require an explicit driveletter /x or /mnt when using unix-like paths on windows - but practical considerations may prove me wrong.. |
|
#It's possible that this function should also ignore the current set of driveletters - and operate completely independent of whether a path actually exists |
|
#This makes it hard to use things like 'file normalize' - which also looks at things like current volume. |
|
# |
|
#Note for example the results of 'which' grep on windows can produce a path like /c/Users/somewhere/bin/grep |
|
#which tcl's file normalize may change to C:/c/Users or X:/c/Users - based on current volumen. Given that C:/c might exist - this can be problematic in a couple of ways. |
|
#The mixing of unix-like and windows commands on the same machine is a large part of the problem.. but this mix is now common |
|
# |
|
#convert /c/etc to C:/etc |
|
set re_slash_x_slash {^/([[:alpha:]]){1}/.*} |
|
set re_slash_else {^/([[:alpha:]]*)(.*)} |
|
set volumes [file volumes] |
|
#exclude things like //zipfs:/ ?? |
|
set driveletters [list] |
|
foreach v $volumes { |
|
if {[regexp {^([[:alpha:]]){1}:/$} $v _ letter]} { |
|
lappend driveletters $letter |
|
} |
|
} |
|
#puts stderr "->$driveletters" |
|
|
|
set path [punk::valcopy $unixypath] ;#take another copy that we can deliberatley shimmer to path and know is separate to the supplied argument |
|
set supplied_pathtype [file pathtype $path] ;#we don't care about the pathtype so much as the act of making this call shimmers to a path internal-rep |
|
|
|
#copy of var that we can treat as a string without affecting path rep |
|
#Note that some but not all read operations will lose path rep e.g 'string length $x' will lose any path-rep $x had, (but 'string equal $x something' won't) |
|
#Todo - make int-rep tests to check stability of these behaviours across Tcl versions! |
|
set strcopy_path [punk::valcopy $path] |
|
|
|
set str_newpath "" |
|
|
|
set have_pathobj 0 |
|
|
|
if {[regexp $re_slash_x_slash $strcopy_path _ letter]} { |
|
#upper case appears to be windows canonical form |
|
set str_newpath [string toupper $letter]:/[string range $strcopy_path 3 end] |
|
} elseif {[regexp {^/mnt/([[:alpha:]]){1}/.*} [string tolower $strcopy_path] _ letter]} { |
|
set str_newpath [string toupper $letter]:/[string range $strcopy_path 7 end] |
|
} elseif {[regexp {^/mnt/([[:alpha:]]){1}$} [string tolower $strcopy_path] _ letter]} { |
|
set str_newpath [string toupper $letter]:/ |
|
} elseif {[regexp $re_slash_else $strcopy_path _ firstpart remainder]} { |
|
#could be for example /c or /something/users |
|
if {[string length $firstpart] == 1} { |
|
set letter $firstpart |
|
set str_newpath [string toupper $letter]:/ |
|
} else { |
|
#according to regex we have a single leading slash |
|
set str_tail [string range $strcopy_path 1 end] |
|
if {$unixyroot eq ""} { |
|
set unixyroot [get_unixyroot] |
|
} else { |
|
file pathtype $unixyroot; #side-effect generates int-rep of type path ) |
|
} |
|
set pathobj [file join $unixyroot $str_tail] |
|
file pathtype $pathobj |
|
set have_pathobj 1 |
|
} |
|
} |
|
|
|
if {!$have_pathobj} { |
|
if {$str_newpath eq ""} { |
|
#dunno - pass through |
|
set pathobj $path |
|
} else { |
|
set pathobj [punk::valcopy $str_newpath] |
|
file pathtype $pathobj |
|
} |
|
} |
|
|
|
|
|
|
|
#puts stderr "=> $path" |
|
#things like 'which' seem to return a path minus the .exe - so we'll just test the containing folder |
|
# |
|
#By now file normalize shouldn't do too many shannanigans related to cwd.. |
|
#We want it to look at cwd for relative paths.. |
|
#but we don't consider things like /c/Users to be relative even on windows where it would normally mean a volume-relative path e.g c:/c/Users if cwd happens to be somewhere on C: at the time. |
|
#if {![file exists [file dirname $path]]} { |
|
# set path [file normalize $path] |
|
# #may still not exist.. that's ok. |
|
#} |
|
|
|
|
|
|
|
#file normalize may change backslashes to forward slashes.. including things like the special \\?\ prefix which is intended to stop windows api from parsing a name |
|
#2023 - this is ok as //?/ also seems to work.. but it is unclear if that is because Tcl is re-converting to backslashes |
|
if {[punk::winpath::illegalname_test $pathobj]} { |
|
set pathobj [punk::winpath::illegalname_fix $pathobj] |
|
} |
|
|
|
return $pathobj |
|
} |
|
|
|
#---------------------------------------------- |
|
#leave the unixywindows related aliases available on all platforms |
|
#interp alias {} cdwin {} punk::unixywindows::cdwin |
|
#interp alias {} cdwindir {} punk::unixywindoes::cdwindir |
|
#interp alias {} towinpath {} punk::unixywindows::towinpath |
|
#interp alias {} windir {} punk::unixywindows::windir |
|
#---------------------------------------------- |
|
|
|
|
|
|
|
} |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Ready |
|
package provide punk::unixywindows [namespace eval punk::unixywindows { |
|
variable version |
|
set version 0.1.0 |
|
}] |
|
return
|
|
|