Julian Noble
3 months ago
31 changed files with 3647 additions and 374 deletions
@ -0,0 +1,468 @@ |
|||||||
|
# -*- 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) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application fauxlink 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license MIT |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin fauxlink_module_fauxlink 0 0.1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {faux link application shortcuts}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {fauxlink .fxlnk}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require fauxlink] |
||||||
|
#[keywords symlink faux fake shortcut toml] |
||||||
|
#[description] |
||||||
|
#[para] A cross platform shortcut/symlink alternative. |
||||||
|
#[para] Unapologetically ugly - but practical in certain circumstances. |
||||||
|
#[para] A solution is required for application-driven filesystem links that survives cross platform moves as well as |
||||||
|
#[para] archiving and packaging systems. |
||||||
|
#[para] The target is specified in a minimally-encoded form in the filename itself - but still human readable. |
||||||
|
#[para] format of name <nominalname>#<encodedtarget>.fxlnk |
||||||
|
#[para] where <nominalname> can be empty - then the effective nominal name is the tail of the <encodedtarget> |
||||||
|
#[para] The + symbol substitutes for forward-slashes. |
||||||
|
#[para] Other chars can be encoded using url-like encoding - (but only up to %7E !) |
||||||
|
#[para] We deliberately treat higher % sequences literally. |
||||||
|
#[para] This means actual uri::urn encoded unicode sequences (e.g %E2%99%A5 [heart]) can remain literal for linking to urls. |
||||||
|
#[para] e.g if an actual + or # is required in a filename or path segment they can be encoded as %2B & %23 |
||||||
|
#[para] e.g a link to a file file#A.txt in parent dir could be: |
||||||
|
#[para] file%23A.txt#..+file%23A.txt.fxlnk |
||||||
|
#[para] or equivalently (but obviously affecting sorting) #..+file%23A.txt.fxlnk |
||||||
|
#[para] The <nominalname> can be unrelated to the actual target |
||||||
|
#[para] e.g datafile.dat#..+file%23A.txt.fxlnk |
||||||
|
#[para] This system has no filesystem support - and must be completely application driven. |
||||||
|
#[para] This can be useful for example in application test packages which may be tarred or zipped and moved cross platform. |
||||||
|
#[para] The target being fully specified in the name means the file doesn't have to be read for the target to be determined |
||||||
|
#[para] Extensions to behaviour should be added in the file as text data in Toml format, |
||||||
|
#[para] with custom data being under a single application-chosen table name |
||||||
|
#[para] The toplevel Toml table [fauxlink] is reserved for core extensions to this system. |
||||||
|
#[para] Aside from the 2 used for delimiting (+ #) |
||||||
|
#[para] certain characters which might normally be allowed in filesystems are required to be encoded |
||||||
|
#[para] e.g space and tab are required to be %20 %09 |
||||||
|
#[para] Others that require encoding are: * ? \ / | : ; " < > |
||||||
|
#[para] The nul character in raw form, when detected, is always mapped away to the empty string - as very few filesystems support it. |
||||||
|
#[para] Control characters and other punctuation is optional to encode. |
||||||
|
#[para] Generally utf-8 should be used where possible and unicode characters left as is where possible on modern systems. |
||||||
|
#[para] Where encoding of unicode is desired in the nominalname or encodedtarget portions it can be specified as %UXXXXXXXX |
||||||
|
#[para] There must be between 1 and 8 X digits following the %U. Interpretation of chars following %U stops at the first non-hex character. |
||||||
|
#[para] This means %Utest would not get any translation as there were no hex digits so it would come out as %Utest |
||||||
|
# |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#https://learn.microsoft.com/en-us/troubleshoot/windows-client/networking/url-encoding-unc-paths-not-url-decoded |
||||||
|
# ie "//server/c/Program files" works but "//server/c/Program%20Files" is now treated by windows as a literal path with %20 in it. |
||||||
|
#Using fauxlink - a link would be: |
||||||
|
# "my-program-files#++server+c+Program%20Files.fxlnk" |
||||||
|
#If we needed the old-style literal %20 it would become |
||||||
|
# "my-program-files#++server+c+Program%2520Files.fxlnk" |
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of fauxlink |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by fauxlink |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6-}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval fauxlink::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace fauxlink::class}] |
||||||
|
#[para] class definitions |
||||||
|
if {[info commands [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 |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval fauxlink { |
||||||
|
namespace export {[a-z]*}; # Convention: export all lowercase |
||||||
|
|
||||||
|
#todo - enforce utf-8 |
||||||
|
|
||||||
|
#literal unicode chars supported by modern filesystems - leave as is - REVIEW |
||||||
|
|
||||||
|
|
||||||
|
variable encode_map |
||||||
|
variable decode_map |
||||||
|
#most filesystems don't allow NULL - map to empty string |
||||||
|
|
||||||
|
#Make sure % is not in encode_map |
||||||
|
set encode_map [dict create\ |
||||||
|
\x00 ""\ |
||||||
|
{ } %20\ |
||||||
|
\t %09\ |
||||||
|
+ %2B\ |
||||||
|
# %23\ |
||||||
|
* %2A\ |
||||||
|
? %3F\ |
||||||
|
\\ %5C\ |
||||||
|
/ %2F\ |
||||||
|
| %7C\ |
||||||
|
: %3A\ |
||||||
|
{;} %3B\ |
||||||
|
{"} %22\ |
||||||
|
< %3C\ |
||||||
|
> %3E\ |
||||||
|
] |
||||||
|
#above have some overlap with ctrl codes below. |
||||||
|
#no big deal as it's a dict |
||||||
|
|
||||||
|
#must_encode |
||||||
|
# + # * ? \ / | : ; " < > <sp> \t |
||||||
|
# also NUL to empty string |
||||||
|
|
||||||
|
# also ctrl chars 01 to 1F (1..31) |
||||||
|
for {set i 1} {$i < 32} {incr i} { |
||||||
|
set ch [format %c $i] |
||||||
|
set enc "%[format %02X $i]" |
||||||
|
set enc_lower [string tolower $enc] |
||||||
|
dict set encode_map $ch $enc |
||||||
|
dict set decode_map $enc $ch |
||||||
|
dict set decode_map $enc_lower $ch |
||||||
|
} |
||||||
|
|
||||||
|
variable must_encode |
||||||
|
set must_encode [dict keys $encode_map] |
||||||
|
|
||||||
|
|
||||||
|
#if they are in |
||||||
|
|
||||||
|
#decode map doesn't include |
||||||
|
# %00 (nul) |
||||||
|
# %2F "/" |
||||||
|
# %2f "/" |
||||||
|
# %7f (del) |
||||||
|
#we exlude the forward slash because we already have + for that - and multiple ways to specify it obscure intention. |
||||||
|
# |
||||||
|
set decode_map [dict merge $decode_map [dict create\ |
||||||
|
%09 \t\ |
||||||
|
%20 { }\ |
||||||
|
%21 "!"\ |
||||||
|
%22 {"}\ |
||||||
|
%23 "#"\ |
||||||
|
%24 "$"\ |
||||||
|
%25 "%"\ |
||||||
|
%26 "&"\ |
||||||
|
%27 "'"\ |
||||||
|
%28 "("\ |
||||||
|
%29 ")"\ |
||||||
|
%2A "*"\ |
||||||
|
%2a "*"\ |
||||||
|
%2B "+"\ |
||||||
|
%2b "+"\ |
||||||
|
%2C ","\ |
||||||
|
%2c ","\ |
||||||
|
%2D "-"\ |
||||||
|
%2d "-"\ |
||||||
|
%2E "."\ |
||||||
|
%2e "."\ |
||||||
|
%3A ":"\ |
||||||
|
%3a ":"\ |
||||||
|
%3B {;}\ |
||||||
|
%3b {;}\ |
||||||
|
%3D "="\ |
||||||
|
%3C "<"\ |
||||||
|
%3c "<"\ |
||||||
|
%3d "="\ |
||||||
|
%3E ">"\ |
||||||
|
%3e ">"\ |
||||||
|
%3F "?"\ |
||||||
|
%3f "?"\ |
||||||
|
%40 "@"\ |
||||||
|
%5B "\["\ |
||||||
|
%5b "\["\ |
||||||
|
%5C "\\"\ |
||||||
|
%5c "\\"\ |
||||||
|
%5D "\]"\ |
||||||
|
%5d "\]"\ |
||||||
|
%5E "^"\ |
||||||
|
%5e "^"\ |
||||||
|
%60 "`"\ |
||||||
|
%7B "{"\ |
||||||
|
%7b "{"\ |
||||||
|
%7C "|"\ |
||||||
|
%7c "|"\ |
||||||
|
%7D "}"\ |
||||||
|
%7d "}"\ |
||||||
|
%7E "~"\ |
||||||
|
%7e "~"\ |
||||||
|
]] |
||||||
|
#Don't go above 7f |
||||||
|
#if we want to specify p |
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace fauxlink}] |
||||||
|
#[para] Core API functions for fauxlink |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
proc resolve {link} { |
||||||
|
variable decode_map |
||||||
|
variable encode_map |
||||||
|
variable must_encode |
||||||
|
set ftail [file tail $link] |
||||||
|
if {[file extension $ftail] ni [list .fxlnk .fauxlink]} { |
||||||
|
error "fauxlink::resolve refusing to process link $link - file extension must be .fxlnk or .fauxlink" |
||||||
|
} |
||||||
|
set linkspec [file rootname $ftail] |
||||||
|
# - any # or + within the target path or name should have been uri encoded as %23 and %2b |
||||||
|
if {[tcl::string::first # $linkspec] < 0} { |
||||||
|
error "fauxlink::resolve error. Link must contain a # (usually at start if name matches target)" |
||||||
|
} |
||||||
|
#only the 1st 2 parts of split on # are significant. |
||||||
|
#if there are more # chars present - the subsequent parts are effectively a comment |
||||||
|
|
||||||
|
#check namepec already has required chars encoded |
||||||
|
lassign [split $linkspec #] namespec targetspec |
||||||
|
#puts stderr "-->namespec $namespec" |
||||||
|
set nametest [tcl::string::map $encode_map $namespec] |
||||||
|
#puts stderr "-->nametest $nametest" |
||||||
|
#nothing should be changed - if there are unencoded chars that must be encoded it is an error |
||||||
|
if {[tcl::string::length $nametest] ne [tcl::string::length $namespec]} { |
||||||
|
set err "fauxlink::resolve invalid chars in name part (section prior to first #)" |
||||||
|
set idx 0 |
||||||
|
foreach ch [split $namespec ""] { |
||||||
|
if {$ch in $must_encode} { |
||||||
|
set enc [dict get $encode_map $ch] |
||||||
|
if {[dict exists $decode_map $enc]} { |
||||||
|
append err " char $idx should be encoded as $enc" \n |
||||||
|
} else { |
||||||
|
append err " no %xx encoding available. Use %UXX if really required" \n |
||||||
|
} |
||||||
|
} |
||||||
|
incr idx |
||||||
|
} |
||||||
|
error $err |
||||||
|
} |
||||||
|
#see comments below regarding 2 rounds and ordering. |
||||||
|
set name [decode_unicode_escapes $namespec] |
||||||
|
set name [tcl::string::map $decode_map $name] |
||||||
|
#puts stderr "-->name: $name" |
||||||
|
|
||||||
|
set targetsegment [split $targetspec +] |
||||||
|
#check each + delimited part of targetspec already has required chars encoded |
||||||
|
set s 0 ;#segment index |
||||||
|
set result_segments [list] |
||||||
|
foreach segment $targetsegment { |
||||||
|
set targettest [tcl::string::map $encode_map $segment] |
||||||
|
if {[tcl::string::length $targettest] ne [tcl::string::length $segment]} { |
||||||
|
set err "fauxlink::resolve invalid chars in targetpath (section following first #)" |
||||||
|
set idx 0 |
||||||
|
foreach ch [split $segment ""] { |
||||||
|
if {$ch in $must_encode} { |
||||||
|
set enc [dict get $encode_map $ch] |
||||||
|
if {[dict exists $decode_map $enc]} { |
||||||
|
append err " segment $s char $idx should be encoded as $enc" \n |
||||||
|
} else { |
||||||
|
append err " no %xx encoding available. Use %UXX if really required" \n |
||||||
|
} |
||||||
|
} |
||||||
|
incr idx |
||||||
|
} |
||||||
|
error $err |
||||||
|
} |
||||||
|
#2 rounds of substitution is possibly asking for trouble.. |
||||||
|
#We allow anything in the resultant segments anyway (as %UXXXX... allows all) |
||||||
|
#so it's not so much about what can be encoded, |
||||||
|
# - but it makes it harder to reason about for users |
||||||
|
# In particular - if we map %XX first it makes %25 -> % substitution tricky |
||||||
|
# if the user requires a literal %UXXX - they can't do %25UXXX |
||||||
|
# the double sub would make it %UXXX -> somechar anyway. |
||||||
|
#we do unicode first - as a 2nd round of %XX substitutions is unlikely to interfere. |
||||||
|
#There is still the opportunity to use things like %U00000025 followed by hex-chars |
||||||
|
# and get some minor surprises, but using %U on ascii is unlikely to be done accidentally - REVIEW |
||||||
|
set segment [decode_unicode_escapes $segment] |
||||||
|
set segment [tcl::string::map $decode_map $segment] |
||||||
|
lappend result_segments $segment |
||||||
|
|
||||||
|
incr s |
||||||
|
} |
||||||
|
set targetpath [join $result_segments /] |
||||||
|
if {$name eq ""} { |
||||||
|
set name [lindex $result_segments end] |
||||||
|
} |
||||||
|
|
||||||
|
return [dict create name $name targetpath $targetpath] |
||||||
|
} |
||||||
|
variable map |
||||||
|
|
||||||
|
#default exclusion of / (%U2f and equivs) |
||||||
|
#this would allow obfuscation of intention - when we have + for that anyway |
||||||
|
proc decode_unicode_escapes {str {exclusions {/ \n \r \x00}}} { |
||||||
|
variable map |
||||||
|
set ucstart [string first %U $str 0] |
||||||
|
if {$ucstart < 0} { |
||||||
|
return $str |
||||||
|
} |
||||||
|
set max 8 |
||||||
|
set map [list] |
||||||
|
set strend [expr {[string length $str]-1}] |
||||||
|
while {$ucstart >= 0} { |
||||||
|
set s $ucstart |
||||||
|
set i [expr {$s +2}] ;#skip the %U |
||||||
|
set hex "" |
||||||
|
while {[tcl::string::length $hex] < 8 && $i <= $strend} { |
||||||
|
set in [string index $str $i] |
||||||
|
if {[tcl::string::is xdigit -strict $in]} { |
||||||
|
append hex $in |
||||||
|
} else { |
||||||
|
break |
||||||
|
} |
||||||
|
incr i |
||||||
|
} |
||||||
|
if {$hex ne ""} { |
||||||
|
incr i -1 |
||||||
|
lappend map $s $i $hex |
||||||
|
} |
||||||
|
set ucstart [tcl::string::first %U $str $i] |
||||||
|
} |
||||||
|
set out "" |
||||||
|
set lastidx -1 |
||||||
|
set e 0 |
||||||
|
foreach {s e hex} $map { |
||||||
|
append out [string range $str $lastidx+1 $s-1] |
||||||
|
set sub [format %c 0x$hex] |
||||||
|
if {$sub in $exclusions} { |
||||||
|
append out %U$hex ;#put it back |
||||||
|
} else { |
||||||
|
append out $sub |
||||||
|
} |
||||||
|
set lastidx $e |
||||||
|
} |
||||||
|
if {$e < [tcl::string::length $str]-1} { |
||||||
|
append out [string range $str $e+1 end] |
||||||
|
} |
||||||
|
return $out |
||||||
|
} |
||||||
|
proc link_as {name target} { |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
#proc sample1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call [fun sample1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of sample1 |
||||||
|
# return "ok" |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace fauxlink ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval fauxlink::lib { |
||||||
|
namespace export {[a-z]*}; # Convention: export all lowercase |
||||||
|
namespace path [namespace parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace fauxlink::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 fauxlink::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
namespace eval fauxlink::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace fauxlink::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide fauxlink [namespace eval fauxlink { |
||||||
|
variable pkg fauxlink |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
@ -0,0 +1,468 @@ |
|||||||
|
# -*- 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) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application fauxlink 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license MIT |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin fauxlink_module_fauxlink 0 0.1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {faux link application shortcuts}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {fauxlink .fxlnk}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require fauxlink] |
||||||
|
#[keywords symlink faux fake shortcut toml] |
||||||
|
#[description] |
||||||
|
#[para] A cross platform shortcut/symlink alternative. |
||||||
|
#[para] Unapologetically ugly - but practical in certain circumstances. |
||||||
|
#[para] A solution is required for application-driven filesystem links that survives cross platform moves as well as |
||||||
|
#[para] archiving and packaging systems. |
||||||
|
#[para] The target is specified in a minimally-encoded form in the filename itself - but still human readable. |
||||||
|
#[para] format of name <nominalname>#<encodedtarget>.fxlnk |
||||||
|
#[para] where <nominalname> can be empty - then the effective nominal name is the tail of the <encodedtarget> |
||||||
|
#[para] The + symbol substitutes for forward-slashes. |
||||||
|
#[para] Other chars can be encoded using url-like encoding - (but only up to %7E !) |
||||||
|
#[para] We deliberately treat higher % sequences literally. |
||||||
|
#[para] This means actual uri::urn encoded unicode sequences (e.g %E2%99%A5 [heart]) can remain literal for linking to urls. |
||||||
|
#[para] e.g if an actual + or # is required in a filename or path segment they can be encoded as %2B & %23 |
||||||
|
#[para] e.g a link to a file file#A.txt in parent dir could be: |
||||||
|
#[para] file%23A.txt#..+file%23A.txt.fxlnk |
||||||
|
#[para] or equivalently (but obviously affecting sorting) #..+file%23A.txt.fxlnk |
||||||
|
#[para] The <nominalname> can be unrelated to the actual target |
||||||
|
#[para] e.g datafile.dat#..+file%23A.txt.fxlnk |
||||||
|
#[para] This system has no filesystem support - and must be completely application driven. |
||||||
|
#[para] This can be useful for example in application test packages which may be tarred or zipped and moved cross platform. |
||||||
|
#[para] The target being fully specified in the name means the file doesn't have to be read for the target to be determined |
||||||
|
#[para] Extensions to behaviour should be added in the file as text data in Toml format, |
||||||
|
#[para] with custom data being under a single application-chosen table name |
||||||
|
#[para] The toplevel Toml table [fauxlink] is reserved for core extensions to this system. |
||||||
|
#[para] Aside from the 2 used for delimiting (+ #) |
||||||
|
#[para] certain characters which might normally be allowed in filesystems are required to be encoded |
||||||
|
#[para] e.g space and tab are required to be %20 %09 |
||||||
|
#[para] Others that require encoding are: * ? \ / | : ; " < > |
||||||
|
#[para] The nul character in raw form, when detected, is always mapped away to the empty string - as very few filesystems support it. |
||||||
|
#[para] Control characters and other punctuation is optional to encode. |
||||||
|
#[para] Generally utf-8 should be used where possible and unicode characters left as is where possible on modern systems. |
||||||
|
#[para] Where encoding of unicode is desired in the nominalname or encodedtarget portions it can be specified as %UXXXXXXXX |
||||||
|
#[para] There must be between 1 and 8 X digits following the %U. Interpretation of chars following %U stops at the first non-hex character. |
||||||
|
#[para] This means %Utest would not get any translation as there were no hex digits so it would come out as %Utest |
||||||
|
# |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#https://learn.microsoft.com/en-us/troubleshoot/windows-client/networking/url-encoding-unc-paths-not-url-decoded |
||||||
|
# ie "//server/c/Program files" works but "//server/c/Program%20Files" is now treated by windows as a literal path with %20 in it. |
||||||
|
#Using fauxlink - a link would be: |
||||||
|
# "my-program-files#++server+c+Program%20Files.fxlnk" |
||||||
|
#If we needed the old-style literal %20 it would become |
||||||
|
# "my-program-files#++server+c+Program%2520Files.fxlnk" |
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of fauxlink |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by fauxlink |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6-}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval fauxlink::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace fauxlink::class}] |
||||||
|
#[para] class definitions |
||||||
|
if {[info commands [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 |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval fauxlink { |
||||||
|
namespace export {[a-z]*}; # Convention: export all lowercase |
||||||
|
|
||||||
|
#todo - enforce utf-8 |
||||||
|
|
||||||
|
#literal unicode chars supported by modern filesystems - leave as is - REVIEW |
||||||
|
|
||||||
|
|
||||||
|
variable encode_map |
||||||
|
variable decode_map |
||||||
|
#most filesystems don't allow NULL - map to empty string |
||||||
|
|
||||||
|
#Make sure % is not in encode_map |
||||||
|
set encode_map [dict create\ |
||||||
|
\x00 ""\ |
||||||
|
{ } %20\ |
||||||
|
\t %09\ |
||||||
|
+ %2B\ |
||||||
|
# %23\ |
||||||
|
* %2A\ |
||||||
|
? %3F\ |
||||||
|
\\ %5C\ |
||||||
|
/ %2F\ |
||||||
|
| %7C\ |
||||||
|
: %3A\ |
||||||
|
{;} %3B\ |
||||||
|
{"} %22\ |
||||||
|
< %3C\ |
||||||
|
> %3E\ |
||||||
|
] |
||||||
|
#above have some overlap with ctrl codes below. |
||||||
|
#no big deal as it's a dict |
||||||
|
|
||||||
|
#must_encode |
||||||
|
# + # * ? \ / | : ; " < > <sp> \t |
||||||
|
# also NUL to empty string |
||||||
|
|
||||||
|
# also ctrl chars 01 to 1F (1..31) |
||||||
|
for {set i 1} {$i < 32} {incr i} { |
||||||
|
set ch [format %c $i] |
||||||
|
set enc "%[format %02X $i]" |
||||||
|
set enc_lower [string tolower $enc] |
||||||
|
dict set encode_map $ch $enc |
||||||
|
dict set decode_map $enc $ch |
||||||
|
dict set decode_map $enc_lower $ch |
||||||
|
} |
||||||
|
|
||||||
|
variable must_encode |
||||||
|
set must_encode [dict keys $encode_map] |
||||||
|
|
||||||
|
|
||||||
|
#if they are in |
||||||
|
|
||||||
|
#decode map doesn't include |
||||||
|
# %00 (nul) |
||||||
|
# %2F "/" |
||||||
|
# %2f "/" |
||||||
|
# %7f (del) |
||||||
|
#we exlude the forward slash because we already have + for that - and multiple ways to specify it obscure intention. |
||||||
|
# |
||||||
|
set decode_map [dict merge $decode_map [dict create\ |
||||||
|
%09 \t\ |
||||||
|
%20 { }\ |
||||||
|
%21 "!"\ |
||||||
|
%22 {"}\ |
||||||
|
%23 "#"\ |
||||||
|
%24 "$"\ |
||||||
|
%25 "%"\ |
||||||
|
%26 "&"\ |
||||||
|
%27 "'"\ |
||||||
|
%28 "("\ |
||||||
|
%29 ")"\ |
||||||
|
%2A "*"\ |
||||||
|
%2a "*"\ |
||||||
|
%2B "+"\ |
||||||
|
%2b "+"\ |
||||||
|
%2C ","\ |
||||||
|
%2c ","\ |
||||||
|
%2D "-"\ |
||||||
|
%2d "-"\ |
||||||
|
%2E "."\ |
||||||
|
%2e "."\ |
||||||
|
%3A ":"\ |
||||||
|
%3a ":"\ |
||||||
|
%3B {;}\ |
||||||
|
%3b {;}\ |
||||||
|
%3D "="\ |
||||||
|
%3C "<"\ |
||||||
|
%3c "<"\ |
||||||
|
%3d "="\ |
||||||
|
%3E ">"\ |
||||||
|
%3e ">"\ |
||||||
|
%3F "?"\ |
||||||
|
%3f "?"\ |
||||||
|
%40 "@"\ |
||||||
|
%5B "\["\ |
||||||
|
%5b "\["\ |
||||||
|
%5C "\\"\ |
||||||
|
%5c "\\"\ |
||||||
|
%5D "\]"\ |
||||||
|
%5d "\]"\ |
||||||
|
%5E "^"\ |
||||||
|
%5e "^"\ |
||||||
|
%60 "`"\ |
||||||
|
%7B "{"\ |
||||||
|
%7b "{"\ |
||||||
|
%7C "|"\ |
||||||
|
%7c "|"\ |
||||||
|
%7D "}"\ |
||||||
|
%7d "}"\ |
||||||
|
%7E "~"\ |
||||||
|
%7e "~"\ |
||||||
|
]] |
||||||
|
#Don't go above 7f |
||||||
|
#if we want to specify p |
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace fauxlink}] |
||||||
|
#[para] Core API functions for fauxlink |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
proc resolve {link} { |
||||||
|
variable decode_map |
||||||
|
variable encode_map |
||||||
|
variable must_encode |
||||||
|
set ftail [file tail $link] |
||||||
|
if {[file extension $ftail] ni [list .fxlnk .fauxlink]} { |
||||||
|
error "fauxlink::resolve refusing to process link $link - file extension must be .fxlnk or .fauxlink" |
||||||
|
} |
||||||
|
set linkspec [file rootname $ftail] |
||||||
|
# - any # or + within the target path or name should have been uri encoded as %23 and %2b |
||||||
|
if {[tcl::string::first # $linkspec] < 0} { |
||||||
|
error "fauxlink::resolve error. Link must contain a # (usually at start if name matches target)" |
||||||
|
} |
||||||
|
#only the 1st 2 parts of split on # are significant. |
||||||
|
#if there are more # chars present - the subsequent parts are effectively a comment |
||||||
|
|
||||||
|
#check namepec already has required chars encoded |
||||||
|
lassign [split $linkspec #] namespec targetspec |
||||||
|
#puts stderr "-->namespec $namespec" |
||||||
|
set nametest [tcl::string::map $encode_map $namespec] |
||||||
|
#puts stderr "-->nametest $nametest" |
||||||
|
#nothing should be changed - if there are unencoded chars that must be encoded it is an error |
||||||
|
if {[tcl::string::length $nametest] ne [tcl::string::length $namespec]} { |
||||||
|
set err "fauxlink::resolve invalid chars in name part (section prior to first #)" |
||||||
|
set idx 0 |
||||||
|
foreach ch [split $namespec ""] { |
||||||
|
if {$ch in $must_encode} { |
||||||
|
set enc [dict get $encode_map $ch] |
||||||
|
if {[dict exists $decode_map $enc]} { |
||||||
|
append err " char $idx should be encoded as $enc" \n |
||||||
|
} else { |
||||||
|
append err " no %xx encoding available. Use %UXX if really required" \n |
||||||
|
} |
||||||
|
} |
||||||
|
incr idx |
||||||
|
} |
||||||
|
error $err |
||||||
|
} |
||||||
|
#see comments below regarding 2 rounds and ordering. |
||||||
|
set name [decode_unicode_escapes $namespec] |
||||||
|
set name [tcl::string::map $decode_map $name] |
||||||
|
#puts stderr "-->name: $name" |
||||||
|
|
||||||
|
set targetsegment [split $targetspec +] |
||||||
|
#check each + delimited part of targetspec already has required chars encoded |
||||||
|
set s 0 ;#segment index |
||||||
|
set result_segments [list] |
||||||
|
foreach segment $targetsegment { |
||||||
|
set targettest [tcl::string::map $encode_map $segment] |
||||||
|
if {[tcl::string::length $targettest] ne [tcl::string::length $segment]} { |
||||||
|
set err "fauxlink::resolve invalid chars in targetpath (section following first #)" |
||||||
|
set idx 0 |
||||||
|
foreach ch [split $segment ""] { |
||||||
|
if {$ch in $must_encode} { |
||||||
|
set enc [dict get $encode_map $ch] |
||||||
|
if {[dict exists $decode_map $enc]} { |
||||||
|
append err " segment $s char $idx should be encoded as $enc" \n |
||||||
|
} else { |
||||||
|
append err " no %xx encoding available. Use %UXX if really required" \n |
||||||
|
} |
||||||
|
} |
||||||
|
incr idx |
||||||
|
} |
||||||
|
error $err |
||||||
|
} |
||||||
|
#2 rounds of substitution is possibly asking for trouble.. |
||||||
|
#We allow anything in the resultant segments anyway (as %UXXXX... allows all) |
||||||
|
#so it's not so much about what can be encoded, |
||||||
|
# - but it makes it harder to reason about for users |
||||||
|
# In particular - if we map %XX first it makes %25 -> % substitution tricky |
||||||
|
# if the user requires a literal %UXXX - they can't do %25UXXX |
||||||
|
# the double sub would make it %UXXX -> somechar anyway. |
||||||
|
#we do unicode first - as a 2nd round of %XX substitutions is unlikely to interfere. |
||||||
|
#There is still the opportunity to use things like %U00000025 followed by hex-chars |
||||||
|
# and get some minor surprises, but using %U on ascii is unlikely to be done accidentally - REVIEW |
||||||
|
set segment [decode_unicode_escapes $segment] |
||||||
|
set segment [tcl::string::map $decode_map $segment] |
||||||
|
lappend result_segments $segment |
||||||
|
|
||||||
|
incr s |
||||||
|
} |
||||||
|
set targetpath [join $result_segments /] |
||||||
|
if {$name eq ""} { |
||||||
|
set name [lindex $result_segments end] |
||||||
|
} |
||||||
|
|
||||||
|
return [dict create name $name targetpath $targetpath] |
||||||
|
} |
||||||
|
variable map |
||||||
|
|
||||||
|
#default exclusion of / (%U2f and equivs) |
||||||
|
#this would allow obfuscation of intention - when we have + for that anyway |
||||||
|
proc decode_unicode_escapes {str {exclusions {/ \n \r \x00}}} { |
||||||
|
variable map |
||||||
|
set ucstart [string first %U $str 0] |
||||||
|
if {$ucstart < 0} { |
||||||
|
return $str |
||||||
|
} |
||||||
|
set max 8 |
||||||
|
set map [list] |
||||||
|
set strend [expr {[string length $str]-1}] |
||||||
|
while {$ucstart >= 0} { |
||||||
|
set s $ucstart |
||||||
|
set i [expr {$s +2}] ;#skip the %U |
||||||
|
set hex "" |
||||||
|
while {[tcl::string::length $hex] < 8 && $i <= $strend} { |
||||||
|
set in [string index $str $i] |
||||||
|
if {[tcl::string::is xdigit -strict $in]} { |
||||||
|
append hex $in |
||||||
|
} else { |
||||||
|
break |
||||||
|
} |
||||||
|
incr i |
||||||
|
} |
||||||
|
if {$hex ne ""} { |
||||||
|
incr i -1 |
||||||
|
lappend map $s $i $hex |
||||||
|
} |
||||||
|
set ucstart [tcl::string::first %U $str $i] |
||||||
|
} |
||||||
|
set out "" |
||||||
|
set lastidx -1 |
||||||
|
set e 0 |
||||||
|
foreach {s e hex} $map { |
||||||
|
append out [string range $str $lastidx+1 $s-1] |
||||||
|
set sub [format %c 0x$hex] |
||||||
|
if {$sub in $exclusions} { |
||||||
|
append out %U$hex ;#put it back |
||||||
|
} else { |
||||||
|
append out $sub |
||||||
|
} |
||||||
|
set lastidx $e |
||||||
|
} |
||||||
|
if {$e < [tcl::string::length $str]-1} { |
||||||
|
append out [string range $str $e+1 end] |
||||||
|
} |
||||||
|
return $out |
||||||
|
} |
||||||
|
proc link_as {name target} { |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
#proc sample1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call [fun sample1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of sample1 |
||||||
|
# return "ok" |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace fauxlink ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval fauxlink::lib { |
||||||
|
namespace export {[a-z]*}; # Convention: export all lowercase |
||||||
|
namespace path [namespace parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace fauxlink::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 fauxlink::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
namespace eval fauxlink::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace fauxlink::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide fauxlink [namespace eval fauxlink { |
||||||
|
variable pkg fauxlink |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
@ -0,0 +1,468 @@ |
|||||||
|
# -*- 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) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application fauxlink 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license MIT |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin fauxlink_module_fauxlink 0 0.1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {faux link application shortcuts}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {fauxlink .fxlnk}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require fauxlink] |
||||||
|
#[keywords symlink faux fake shortcut toml] |
||||||
|
#[description] |
||||||
|
#[para] A cross platform shortcut/symlink alternative. |
||||||
|
#[para] Unapologetically ugly - but practical in certain circumstances. |
||||||
|
#[para] A solution is required for application-driven filesystem links that survives cross platform moves as well as |
||||||
|
#[para] archiving and packaging systems. |
||||||
|
#[para] The target is specified in a minimally-encoded form in the filename itself - but still human readable. |
||||||
|
#[para] format of name <nominalname>#<encodedtarget>.fxlnk |
||||||
|
#[para] where <nominalname> can be empty - then the effective nominal name is the tail of the <encodedtarget> |
||||||
|
#[para] The + symbol substitutes for forward-slashes. |
||||||
|
#[para] Other chars can be encoded using url-like encoding - (but only up to %7E !) |
||||||
|
#[para] We deliberately treat higher % sequences literally. |
||||||
|
#[para] This means actual uri::urn encoded unicode sequences (e.g %E2%99%A5 [heart]) can remain literal for linking to urls. |
||||||
|
#[para] e.g if an actual + or # is required in a filename or path segment they can be encoded as %2B & %23 |
||||||
|
#[para] e.g a link to a file file#A.txt in parent dir could be: |
||||||
|
#[para] file%23A.txt#..+file%23A.txt.fxlnk |
||||||
|
#[para] or equivalently (but obviously affecting sorting) #..+file%23A.txt.fxlnk |
||||||
|
#[para] The <nominalname> can be unrelated to the actual target |
||||||
|
#[para] e.g datafile.dat#..+file%23A.txt.fxlnk |
||||||
|
#[para] This system has no filesystem support - and must be completely application driven. |
||||||
|
#[para] This can be useful for example in application test packages which may be tarred or zipped and moved cross platform. |
||||||
|
#[para] The target being fully specified in the name means the file doesn't have to be read for the target to be determined |
||||||
|
#[para] Extensions to behaviour should be added in the file as text data in Toml format, |
||||||
|
#[para] with custom data being under a single application-chosen table name |
||||||
|
#[para] The toplevel Toml table [fauxlink] is reserved for core extensions to this system. |
||||||
|
#[para] Aside from the 2 used for delimiting (+ #) |
||||||
|
#[para] certain characters which might normally be allowed in filesystems are required to be encoded |
||||||
|
#[para] e.g space and tab are required to be %20 %09 |
||||||
|
#[para] Others that require encoding are: * ? \ / | : ; " < > |
||||||
|
#[para] The nul character in raw form, when detected, is always mapped away to the empty string - as very few filesystems support it. |
||||||
|
#[para] Control characters and other punctuation is optional to encode. |
||||||
|
#[para] Generally utf-8 should be used where possible and unicode characters left as is where possible on modern systems. |
||||||
|
#[para] Where encoding of unicode is desired in the nominalname or encodedtarget portions it can be specified as %UXXXXXXXX |
||||||
|
#[para] There must be between 1 and 8 X digits following the %U. Interpretation of chars following %U stops at the first non-hex character. |
||||||
|
#[para] This means %Utest would not get any translation as there were no hex digits so it would come out as %Utest |
||||||
|
# |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#https://learn.microsoft.com/en-us/troubleshoot/windows-client/networking/url-encoding-unc-paths-not-url-decoded |
||||||
|
# ie "//server/c/Program files" works but "//server/c/Program%20Files" is now treated by windows as a literal path with %20 in it. |
||||||
|
#Using fauxlink - a link would be: |
||||||
|
# "my-program-files#++server+c+Program%20Files.fxlnk" |
||||||
|
#If we needed the old-style literal %20 it would become |
||||||
|
# "my-program-files#++server+c+Program%2520Files.fxlnk" |
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of fauxlink |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by fauxlink |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6-}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval fauxlink::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace fauxlink::class}] |
||||||
|
#[para] class definitions |
||||||
|
if {[info commands [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 |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval fauxlink { |
||||||
|
namespace export {[a-z]*}; # Convention: export all lowercase |
||||||
|
|
||||||
|
#todo - enforce utf-8 |
||||||
|
|
||||||
|
#literal unicode chars supported by modern filesystems - leave as is - REVIEW |
||||||
|
|
||||||
|
|
||||||
|
variable encode_map |
||||||
|
variable decode_map |
||||||
|
#most filesystems don't allow NULL - map to empty string |
||||||
|
|
||||||
|
#Make sure % is not in encode_map |
||||||
|
set encode_map [dict create\ |
||||||
|
\x00 ""\ |
||||||
|
{ } %20\ |
||||||
|
\t %09\ |
||||||
|
+ %2B\ |
||||||
|
# %23\ |
||||||
|
* %2A\ |
||||||
|
? %3F\ |
||||||
|
\\ %5C\ |
||||||
|
/ %2F\ |
||||||
|
| %7C\ |
||||||
|
: %3A\ |
||||||
|
{;} %3B\ |
||||||
|
{"} %22\ |
||||||
|
< %3C\ |
||||||
|
> %3E\ |
||||||
|
] |
||||||
|
#above have some overlap with ctrl codes below. |
||||||
|
#no big deal as it's a dict |
||||||
|
|
||||||
|
#must_encode |
||||||
|
# + # * ? \ / | : ; " < > <sp> \t |
||||||
|
# also NUL to empty string |
||||||
|
|
||||||
|
# also ctrl chars 01 to 1F (1..31) |
||||||
|
for {set i 1} {$i < 32} {incr i} { |
||||||
|
set ch [format %c $i] |
||||||
|
set enc "%[format %02X $i]" |
||||||
|
set enc_lower [string tolower $enc] |
||||||
|
dict set encode_map $ch $enc |
||||||
|
dict set decode_map $enc $ch |
||||||
|
dict set decode_map $enc_lower $ch |
||||||
|
} |
||||||
|
|
||||||
|
variable must_encode |
||||||
|
set must_encode [dict keys $encode_map] |
||||||
|
|
||||||
|
|
||||||
|
#if they are in |
||||||
|
|
||||||
|
#decode map doesn't include |
||||||
|
# %00 (nul) |
||||||
|
# %2F "/" |
||||||
|
# %2f "/" |
||||||
|
# %7f (del) |
||||||
|
#we exlude the forward slash because we already have + for that - and multiple ways to specify it obscure intention. |
||||||
|
# |
||||||
|
set decode_map [dict merge $decode_map [dict create\ |
||||||
|
%09 \t\ |
||||||
|
%20 { }\ |
||||||
|
%21 "!"\ |
||||||
|
%22 {"}\ |
||||||
|
%23 "#"\ |
||||||
|
%24 "$"\ |
||||||
|
%25 "%"\ |
||||||
|
%26 "&"\ |
||||||
|
%27 "'"\ |
||||||
|
%28 "("\ |
||||||
|
%29 ")"\ |
||||||
|
%2A "*"\ |
||||||
|
%2a "*"\ |
||||||
|
%2B "+"\ |
||||||
|
%2b "+"\ |
||||||
|
%2C ","\ |
||||||
|
%2c ","\ |
||||||
|
%2D "-"\ |
||||||
|
%2d "-"\ |
||||||
|
%2E "."\ |
||||||
|
%2e "."\ |
||||||
|
%3A ":"\ |
||||||
|
%3a ":"\ |
||||||
|
%3B {;}\ |
||||||
|
%3b {;}\ |
||||||
|
%3D "="\ |
||||||
|
%3C "<"\ |
||||||
|
%3c "<"\ |
||||||
|
%3d "="\ |
||||||
|
%3E ">"\ |
||||||
|
%3e ">"\ |
||||||
|
%3F "?"\ |
||||||
|
%3f "?"\ |
||||||
|
%40 "@"\ |
||||||
|
%5B "\["\ |
||||||
|
%5b "\["\ |
||||||
|
%5C "\\"\ |
||||||
|
%5c "\\"\ |
||||||
|
%5D "\]"\ |
||||||
|
%5d "\]"\ |
||||||
|
%5E "^"\ |
||||||
|
%5e "^"\ |
||||||
|
%60 "`"\ |
||||||
|
%7B "{"\ |
||||||
|
%7b "{"\ |
||||||
|
%7C "|"\ |
||||||
|
%7c "|"\ |
||||||
|
%7D "}"\ |
||||||
|
%7d "}"\ |
||||||
|
%7E "~"\ |
||||||
|
%7e "~"\ |
||||||
|
]] |
||||||
|
#Don't go above 7f |
||||||
|
#if we want to specify p |
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace fauxlink}] |
||||||
|
#[para] Core API functions for fauxlink |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
proc resolve {link} { |
||||||
|
variable decode_map |
||||||
|
variable encode_map |
||||||
|
variable must_encode |
||||||
|
set ftail [file tail $link] |
||||||
|
if {[file extension $ftail] ni [list .fxlnk .fauxlink]} { |
||||||
|
error "fauxlink::resolve refusing to process link $link - file extension must be .fxlnk or .fauxlink" |
||||||
|
} |
||||||
|
set linkspec [file rootname $ftail] |
||||||
|
# - any # or + within the target path or name should have been uri encoded as %23 and %2b |
||||||
|
if {[tcl::string::first # $linkspec] < 0} { |
||||||
|
error "fauxlink::resolve error. Link must contain a # (usually at start if name matches target)" |
||||||
|
} |
||||||
|
#only the 1st 2 parts of split on # are significant. |
||||||
|
#if there are more # chars present - the subsequent parts are effectively a comment |
||||||
|
|
||||||
|
#check namepec already has required chars encoded |
||||||
|
lassign [split $linkspec #] namespec targetspec |
||||||
|
#puts stderr "-->namespec $namespec" |
||||||
|
set nametest [tcl::string::map $encode_map $namespec] |
||||||
|
#puts stderr "-->nametest $nametest" |
||||||
|
#nothing should be changed - if there are unencoded chars that must be encoded it is an error |
||||||
|
if {[tcl::string::length $nametest] ne [tcl::string::length $namespec]} { |
||||||
|
set err "fauxlink::resolve invalid chars in name part (section prior to first #)" |
||||||
|
set idx 0 |
||||||
|
foreach ch [split $namespec ""] { |
||||||
|
if {$ch in $must_encode} { |
||||||
|
set enc [dict get $encode_map $ch] |
||||||
|
if {[dict exists $decode_map $enc]} { |
||||||
|
append err " char $idx should be encoded as $enc" \n |
||||||
|
} else { |
||||||
|
append err " no %xx encoding available. Use %UXX if really required" \n |
||||||
|
} |
||||||
|
} |
||||||
|
incr idx |
||||||
|
} |
||||||
|
error $err |
||||||
|
} |
||||||
|
#see comments below regarding 2 rounds and ordering. |
||||||
|
set name [decode_unicode_escapes $namespec] |
||||||
|
set name [tcl::string::map $decode_map $name] |
||||||
|
#puts stderr "-->name: $name" |
||||||
|
|
||||||
|
set targetsegment [split $targetspec +] |
||||||
|
#check each + delimited part of targetspec already has required chars encoded |
||||||
|
set s 0 ;#segment index |
||||||
|
set result_segments [list] |
||||||
|
foreach segment $targetsegment { |
||||||
|
set targettest [tcl::string::map $encode_map $segment] |
||||||
|
if {[tcl::string::length $targettest] ne [tcl::string::length $segment]} { |
||||||
|
set err "fauxlink::resolve invalid chars in targetpath (section following first #)" |
||||||
|
set idx 0 |
||||||
|
foreach ch [split $segment ""] { |
||||||
|
if {$ch in $must_encode} { |
||||||
|
set enc [dict get $encode_map $ch] |
||||||
|
if {[dict exists $decode_map $enc]} { |
||||||
|
append err " segment $s char $idx should be encoded as $enc" \n |
||||||
|
} else { |
||||||
|
append err " no %xx encoding available. Use %UXX if really required" \n |
||||||
|
} |
||||||
|
} |
||||||
|
incr idx |
||||||
|
} |
||||||
|
error $err |
||||||
|
} |
||||||
|
#2 rounds of substitution is possibly asking for trouble.. |
||||||
|
#We allow anything in the resultant segments anyway (as %UXXXX... allows all) |
||||||
|
#so it's not so much about what can be encoded, |
||||||
|
# - but it makes it harder to reason about for users |
||||||
|
# In particular - if we map %XX first it makes %25 -> % substitution tricky |
||||||
|
# if the user requires a literal %UXXX - they can't do %25UXXX |
||||||
|
# the double sub would make it %UXXX -> somechar anyway. |
||||||
|
#we do unicode first - as a 2nd round of %XX substitutions is unlikely to interfere. |
||||||
|
#There is still the opportunity to use things like %U00000025 followed by hex-chars |
||||||
|
# and get some minor surprises, but using %U on ascii is unlikely to be done accidentally - REVIEW |
||||||
|
set segment [decode_unicode_escapes $segment] |
||||||
|
set segment [tcl::string::map $decode_map $segment] |
||||||
|
lappend result_segments $segment |
||||||
|
|
||||||
|
incr s |
||||||
|
} |
||||||
|
set targetpath [join $result_segments /] |
||||||
|
if {$name eq ""} { |
||||||
|
set name [lindex $result_segments end] |
||||||
|
} |
||||||
|
|
||||||
|
return [dict create name $name targetpath $targetpath] |
||||||
|
} |
||||||
|
variable map |
||||||
|
|
||||||
|
#default exclusion of / (%U2f and equivs) |
||||||
|
#this would allow obfuscation of intention - when we have + for that anyway |
||||||
|
proc decode_unicode_escapes {str {exclusions {/ \n \r \x00}}} { |
||||||
|
variable map |
||||||
|
set ucstart [string first %U $str 0] |
||||||
|
if {$ucstart < 0} { |
||||||
|
return $str |
||||||
|
} |
||||||
|
set max 8 |
||||||
|
set map [list] |
||||||
|
set strend [expr {[string length $str]-1}] |
||||||
|
while {$ucstart >= 0} { |
||||||
|
set s $ucstart |
||||||
|
set i [expr {$s +2}] ;#skip the %U |
||||||
|
set hex "" |
||||||
|
while {[tcl::string::length $hex] < 8 && $i <= $strend} { |
||||||
|
set in [string index $str $i] |
||||||
|
if {[tcl::string::is xdigit -strict $in]} { |
||||||
|
append hex $in |
||||||
|
} else { |
||||||
|
break |
||||||
|
} |
||||||
|
incr i |
||||||
|
} |
||||||
|
if {$hex ne ""} { |
||||||
|
incr i -1 |
||||||
|
lappend map $s $i $hex |
||||||
|
} |
||||||
|
set ucstart [tcl::string::first %U $str $i] |
||||||
|
} |
||||||
|
set out "" |
||||||
|
set lastidx -1 |
||||||
|
set e 0 |
||||||
|
foreach {s e hex} $map { |
||||||
|
append out [string range $str $lastidx+1 $s-1] |
||||||
|
set sub [format %c 0x$hex] |
||||||
|
if {$sub in $exclusions} { |
||||||
|
append out %U$hex ;#put it back |
||||||
|
} else { |
||||||
|
append out $sub |
||||||
|
} |
||||||
|
set lastidx $e |
||||||
|
} |
||||||
|
if {$e < [tcl::string::length $str]-1} { |
||||||
|
append out [string range $str $e+1 end] |
||||||
|
} |
||||||
|
return $out |
||||||
|
} |
||||||
|
proc link_as {name target} { |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
#proc sample1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call [fun sample1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of sample1 |
||||||
|
# return "ok" |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace fauxlink ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval fauxlink::lib { |
||||||
|
namespace export {[a-z]*}; # Convention: export all lowercase |
||||||
|
namespace path [namespace parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace fauxlink::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 fauxlink::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
namespace eval fauxlink::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace fauxlink::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide fauxlink [namespace eval fauxlink { |
||||||
|
variable pkg fauxlink |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
@ -0,0 +1,468 @@ |
|||||||
|
# -*- 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) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application fauxlink 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license MIT |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin fauxlink_module_fauxlink 0 0.1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {faux link application shortcuts}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {fauxlink .fxlnk}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require fauxlink] |
||||||
|
#[keywords symlink faux fake shortcut toml] |
||||||
|
#[description] |
||||||
|
#[para] A cross platform shortcut/symlink alternative. |
||||||
|
#[para] Unapologetically ugly - but practical in certain circumstances. |
||||||
|
#[para] A solution is required for application-driven filesystem links that survives cross platform moves as well as |
||||||
|
#[para] archiving and packaging systems. |
||||||
|
#[para] The target is specified in a minimally-encoded form in the filename itself - but still human readable. |
||||||
|
#[para] format of name <nominalname>#<encodedtarget>.fxlnk |
||||||
|
#[para] where <nominalname> can be empty - then the effective nominal name is the tail of the <encodedtarget> |
||||||
|
#[para] The + symbol substitutes for forward-slashes. |
||||||
|
#[para] Other chars can be encoded using url-like encoding - (but only up to %7E !) |
||||||
|
#[para] We deliberately treat higher % sequences literally. |
||||||
|
#[para] This means actual uri::urn encoded unicode sequences (e.g %E2%99%A5 [heart]) can remain literal for linking to urls. |
||||||
|
#[para] e.g if an actual + or # is required in a filename or path segment they can be encoded as %2B & %23 |
||||||
|
#[para] e.g a link to a file file#A.txt in parent dir could be: |
||||||
|
#[para] file%23A.txt#..+file%23A.txt.fxlnk |
||||||
|
#[para] or equivalently (but obviously affecting sorting) #..+file%23A.txt.fxlnk |
||||||
|
#[para] The <nominalname> can be unrelated to the actual target |
||||||
|
#[para] e.g datafile.dat#..+file%23A.txt.fxlnk |
||||||
|
#[para] This system has no filesystem support - and must be completely application driven. |
||||||
|
#[para] This can be useful for example in application test packages which may be tarred or zipped and moved cross platform. |
||||||
|
#[para] The target being fully specified in the name means the file doesn't have to be read for the target to be determined |
||||||
|
#[para] Extensions to behaviour should be added in the file as text data in Toml format, |
||||||
|
#[para] with custom data being under a single application-chosen table name |
||||||
|
#[para] The toplevel Toml table [fauxlink] is reserved for core extensions to this system. |
||||||
|
#[para] Aside from the 2 used for delimiting (+ #) |
||||||
|
#[para] certain characters which might normally be allowed in filesystems are required to be encoded |
||||||
|
#[para] e.g space and tab are required to be %20 %09 |
||||||
|
#[para] Others that require encoding are: * ? \ / | : ; " < > |
||||||
|
#[para] The nul character in raw form, when detected, is always mapped away to the empty string - as very few filesystems support it. |
||||||
|
#[para] Control characters and other punctuation is optional to encode. |
||||||
|
#[para] Generally utf-8 should be used where possible and unicode characters left as is where possible on modern systems. |
||||||
|
#[para] Where encoding of unicode is desired in the nominalname or encodedtarget portions it can be specified as %UXXXXXXXX |
||||||
|
#[para] There must be between 1 and 8 X digits following the %U. Interpretation of chars following %U stops at the first non-hex character. |
||||||
|
#[para] This means %Utest would not get any translation as there were no hex digits so it would come out as %Utest |
||||||
|
# |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#https://learn.microsoft.com/en-us/troubleshoot/windows-client/networking/url-encoding-unc-paths-not-url-decoded |
||||||
|
# ie "//server/c/Program files" works but "//server/c/Program%20Files" is now treated by windows as a literal path with %20 in it. |
||||||
|
#Using fauxlink - a link would be: |
||||||
|
# "my-program-files#++server+c+Program%20Files.fxlnk" |
||||||
|
#If we needed the old-style literal %20 it would become |
||||||
|
# "my-program-files#++server+c+Program%2520Files.fxlnk" |
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of fauxlink |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by fauxlink |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6-}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval fauxlink::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace fauxlink::class}] |
||||||
|
#[para] class definitions |
||||||
|
if {[info commands [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 |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval fauxlink { |
||||||
|
namespace export {[a-z]*}; # Convention: export all lowercase |
||||||
|
|
||||||
|
#todo - enforce utf-8 |
||||||
|
|
||||||
|
#literal unicode chars supported by modern filesystems - leave as is - REVIEW |
||||||
|
|
||||||
|
|
||||||
|
variable encode_map |
||||||
|
variable decode_map |
||||||
|
#most filesystems don't allow NULL - map to empty string |
||||||
|
|
||||||
|
#Make sure % is not in encode_map |
||||||
|
set encode_map [dict create\ |
||||||
|
\x00 ""\ |
||||||
|
{ } %20\ |
||||||
|
\t %09\ |
||||||
|
+ %2B\ |
||||||
|
# %23\ |
||||||
|
* %2A\ |
||||||
|
? %3F\ |
||||||
|
\\ %5C\ |
||||||
|
/ %2F\ |
||||||
|
| %7C\ |
||||||
|
: %3A\ |
||||||
|
{;} %3B\ |
||||||
|
{"} %22\ |
||||||
|
< %3C\ |
||||||
|
> %3E\ |
||||||
|
] |
||||||
|
#above have some overlap with ctrl codes below. |
||||||
|
#no big deal as it's a dict |
||||||
|
|
||||||
|
#must_encode |
||||||
|
# + # * ? \ / | : ; " < > <sp> \t |
||||||
|
# also NUL to empty string |
||||||
|
|
||||||
|
# also ctrl chars 01 to 1F (1..31) |
||||||
|
for {set i 1} {$i < 32} {incr i} { |
||||||
|
set ch [format %c $i] |
||||||
|
set enc "%[format %02X $i]" |
||||||
|
set enc_lower [string tolower $enc] |
||||||
|
dict set encode_map $ch $enc |
||||||
|
dict set decode_map $enc $ch |
||||||
|
dict set decode_map $enc_lower $ch |
||||||
|
} |
||||||
|
|
||||||
|
variable must_encode |
||||||
|
set must_encode [dict keys $encode_map] |
||||||
|
|
||||||
|
|
||||||
|
#if they are in |
||||||
|
|
||||||
|
#decode map doesn't include |
||||||
|
# %00 (nul) |
||||||
|
# %2F "/" |
||||||
|
# %2f "/" |
||||||
|
# %7f (del) |
||||||
|
#we exlude the forward slash because we already have + for that - and multiple ways to specify it obscure intention. |
||||||
|
# |
||||||
|
set decode_map [dict merge $decode_map [dict create\ |
||||||
|
%09 \t\ |
||||||
|
%20 { }\ |
||||||
|
%21 "!"\ |
||||||
|
%22 {"}\ |
||||||
|
%23 "#"\ |
||||||
|
%24 "$"\ |
||||||
|
%25 "%"\ |
||||||
|
%26 "&"\ |
||||||
|
%27 "'"\ |
||||||
|
%28 "("\ |
||||||
|
%29 ")"\ |
||||||
|
%2A "*"\ |
||||||
|
%2a "*"\ |
||||||
|
%2B "+"\ |
||||||
|
%2b "+"\ |
||||||
|
%2C ","\ |
||||||
|
%2c ","\ |
||||||
|
%2D "-"\ |
||||||
|
%2d "-"\ |
||||||
|
%2E "."\ |
||||||
|
%2e "."\ |
||||||
|
%3A ":"\ |
||||||
|
%3a ":"\ |
||||||
|
%3B {;}\ |
||||||
|
%3b {;}\ |
||||||
|
%3D "="\ |
||||||
|
%3C "<"\ |
||||||
|
%3c "<"\ |
||||||
|
%3d "="\ |
||||||
|
%3E ">"\ |
||||||
|
%3e ">"\ |
||||||
|
%3F "?"\ |
||||||
|
%3f "?"\ |
||||||
|
%40 "@"\ |
||||||
|
%5B "\["\ |
||||||
|
%5b "\["\ |
||||||
|
%5C "\\"\ |
||||||
|
%5c "\\"\ |
||||||
|
%5D "\]"\ |
||||||
|
%5d "\]"\ |
||||||
|
%5E "^"\ |
||||||
|
%5e "^"\ |
||||||
|
%60 "`"\ |
||||||
|
%7B "{"\ |
||||||
|
%7b "{"\ |
||||||
|
%7C "|"\ |
||||||
|
%7c "|"\ |
||||||
|
%7D "}"\ |
||||||
|
%7d "}"\ |
||||||
|
%7E "~"\ |
||||||
|
%7e "~"\ |
||||||
|
]] |
||||||
|
#Don't go above 7f |
||||||
|
#if we want to specify p |
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace fauxlink}] |
||||||
|
#[para] Core API functions for fauxlink |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
proc resolve {link} { |
||||||
|
variable decode_map |
||||||
|
variable encode_map |
||||||
|
variable must_encode |
||||||
|
set ftail [file tail $link] |
||||||
|
if {[file extension $ftail] ni [list .fxlnk .fauxlink]} { |
||||||
|
error "fauxlink::resolve refusing to process link $link - file extension must be .fxlnk or .fauxlink" |
||||||
|
} |
||||||
|
set linkspec [file rootname $ftail] |
||||||
|
# - any # or + within the target path or name should have been uri encoded as %23 and %2b |
||||||
|
if {[tcl::string::first # $linkspec] < 0} { |
||||||
|
error "fauxlink::resolve error. Link must contain a # (usually at start if name matches target)" |
||||||
|
} |
||||||
|
#only the 1st 2 parts of split on # are significant. |
||||||
|
#if there are more # chars present - the subsequent parts are effectively a comment |
||||||
|
|
||||||
|
#check namepec already has required chars encoded |
||||||
|
lassign [split $linkspec #] namespec targetspec |
||||||
|
#puts stderr "-->namespec $namespec" |
||||||
|
set nametest [tcl::string::map $encode_map $namespec] |
||||||
|
#puts stderr "-->nametest $nametest" |
||||||
|
#nothing should be changed - if there are unencoded chars that must be encoded it is an error |
||||||
|
if {[tcl::string::length $nametest] ne [tcl::string::length $namespec]} { |
||||||
|
set err "fauxlink::resolve invalid chars in name part (section prior to first #)" |
||||||
|
set idx 0 |
||||||
|
foreach ch [split $namespec ""] { |
||||||
|
if {$ch in $must_encode} { |
||||||
|
set enc [dict get $encode_map $ch] |
||||||
|
if {[dict exists $decode_map $enc]} { |
||||||
|
append err " char $idx should be encoded as $enc" \n |
||||||
|
} else { |
||||||
|
append err " no %xx encoding available. Use %UXX if really required" \n |
||||||
|
} |
||||||
|
} |
||||||
|
incr idx |
||||||
|
} |
||||||
|
error $err |
||||||
|
} |
||||||
|
#see comments below regarding 2 rounds and ordering. |
||||||
|
set name [decode_unicode_escapes $namespec] |
||||||
|
set name [tcl::string::map $decode_map $name] |
||||||
|
#puts stderr "-->name: $name" |
||||||
|
|
||||||
|
set targetsegment [split $targetspec +] |
||||||
|
#check each + delimited part of targetspec already has required chars encoded |
||||||
|
set s 0 ;#segment index |
||||||
|
set result_segments [list] |
||||||
|
foreach segment $targetsegment { |
||||||
|
set targettest [tcl::string::map $encode_map $segment] |
||||||
|
if {[tcl::string::length $targettest] ne [tcl::string::length $segment]} { |
||||||
|
set err "fauxlink::resolve invalid chars in targetpath (section following first #)" |
||||||
|
set idx 0 |
||||||
|
foreach ch [split $segment ""] { |
||||||
|
if {$ch in $must_encode} { |
||||||
|
set enc [dict get $encode_map $ch] |
||||||
|
if {[dict exists $decode_map $enc]} { |
||||||
|
append err " segment $s char $idx should be encoded as $enc" \n |
||||||
|
} else { |
||||||
|
append err " no %xx encoding available. Use %UXX if really required" \n |
||||||
|
} |
||||||
|
} |
||||||
|
incr idx |
||||||
|
} |
||||||
|
error $err |
||||||
|
} |
||||||
|
#2 rounds of substitution is possibly asking for trouble.. |
||||||
|
#We allow anything in the resultant segments anyway (as %UXXXX... allows all) |
||||||
|
#so it's not so much about what can be encoded, |
||||||
|
# - but it makes it harder to reason about for users |
||||||
|
# In particular - if we map %XX first it makes %25 -> % substitution tricky |
||||||
|
# if the user requires a literal %UXXX - they can't do %25UXXX |
||||||
|
# the double sub would make it %UXXX -> somechar anyway. |
||||||
|
#we do unicode first - as a 2nd round of %XX substitutions is unlikely to interfere. |
||||||
|
#There is still the opportunity to use things like %U00000025 followed by hex-chars |
||||||
|
# and get some minor surprises, but using %U on ascii is unlikely to be done accidentally - REVIEW |
||||||
|
set segment [decode_unicode_escapes $segment] |
||||||
|
set segment [tcl::string::map $decode_map $segment] |
||||||
|
lappend result_segments $segment |
||||||
|
|
||||||
|
incr s |
||||||
|
} |
||||||
|
set targetpath [join $result_segments /] |
||||||
|
if {$name eq ""} { |
||||||
|
set name [lindex $result_segments end] |
||||||
|
} |
||||||
|
|
||||||
|
return [dict create name $name targetpath $targetpath] |
||||||
|
} |
||||||
|
variable map |
||||||
|
|
||||||
|
#default exclusion of / (%U2f and equivs) |
||||||
|
#this would allow obfuscation of intention - when we have + for that anyway |
||||||
|
proc decode_unicode_escapes {str {exclusions {/ \n \r \x00}}} { |
||||||
|
variable map |
||||||
|
set ucstart [string first %U $str 0] |
||||||
|
if {$ucstart < 0} { |
||||||
|
return $str |
||||||
|
} |
||||||
|
set max 8 |
||||||
|
set map [list] |
||||||
|
set strend [expr {[string length $str]-1}] |
||||||
|
while {$ucstart >= 0} { |
||||||
|
set s $ucstart |
||||||
|
set i [expr {$s +2}] ;#skip the %U |
||||||
|
set hex "" |
||||||
|
while {[tcl::string::length $hex] < 8 && $i <= $strend} { |
||||||
|
set in [string index $str $i] |
||||||
|
if {[tcl::string::is xdigit -strict $in]} { |
||||||
|
append hex $in |
||||||
|
} else { |
||||||
|
break |
||||||
|
} |
||||||
|
incr i |
||||||
|
} |
||||||
|
if {$hex ne ""} { |
||||||
|
incr i -1 |
||||||
|
lappend map $s $i $hex |
||||||
|
} |
||||||
|
set ucstart [tcl::string::first %U $str $i] |
||||||
|
} |
||||||
|
set out "" |
||||||
|
set lastidx -1 |
||||||
|
set e 0 |
||||||
|
foreach {s e hex} $map { |
||||||
|
append out [string range $str $lastidx+1 $s-1] |
||||||
|
set sub [format %c 0x$hex] |
||||||
|
if {$sub in $exclusions} { |
||||||
|
append out %U$hex ;#put it back |
||||||
|
} else { |
||||||
|
append out $sub |
||||||
|
} |
||||||
|
set lastidx $e |
||||||
|
} |
||||||
|
if {$e < [tcl::string::length $str]-1} { |
||||||
|
append out [string range $str $e+1 end] |
||||||
|
} |
||||||
|
return $out |
||||||
|
} |
||||||
|
proc link_as {name target} { |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
#proc sample1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call [fun sample1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of sample1 |
||||||
|
# return "ok" |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace fauxlink ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval fauxlink::lib { |
||||||
|
namespace export {[a-z]*}; # Convention: export all lowercase |
||||||
|
namespace path [namespace parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace fauxlink::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 fauxlink::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
namespace eval fauxlink::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace fauxlink::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide fauxlink [namespace eval fauxlink { |
||||||
|
variable pkg fauxlink |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
@ -0,0 +1,561 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: shellspy/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::winlnk 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license MIT |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin shellspy_module_punk::winlnk 0 0.1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {windows shortcut .lnk library}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {punk::winlnk}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::winlnk] |
||||||
|
#[keywords module shortcut lnk parse windows crossplatform] |
||||||
|
#[description] |
||||||
|
#[para] Tools for reading windows shortcuts (.lnk files) on any platform |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of punk::winlnk |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] Windows shortcuts are a binary format file with a .lnk extension |
||||||
|
#[para] Shell Link (.LNK) Binary File Format is documented in [MS_SHLLINK].pdf published by Microsoft. |
||||||
|
#[para] Revision 8.0 published 2024-04-23 |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by punk::winlnk |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6}] |
||||||
|
|
||||||
|
#TODO - logger |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#tcl::namespace::eval punk::winlnk::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::winlnk::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::winlnk { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
#variable xyz |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::winlnk}] |
||||||
|
#[para] Core API functions for punk::winlnk |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
|
||||||
|
variable magic_HeaderSize "0000004C" ;#HeaderSize MUST equal this |
||||||
|
variable magic_LinkCLSID "00021401-0000-0000-C000-000000000046" ;#LinkCLSID MUST equal this |
||||||
|
|
||||||
|
proc Get_contents {path {bytes all}} { |
||||||
|
if {![file exists $path] || [file type $path] ne "file"} { |
||||||
|
error "punk::winlnk::get_contents cannot find a filesystem object of type 'file' at location: $path" |
||||||
|
} |
||||||
|
set fd [open $path r] |
||||||
|
chan configure $fd -translation binary -encoding iso8859-1 |
||||||
|
if {$bytes eq "all"} { |
||||||
|
set data [read $fd] |
||||||
|
} else { |
||||||
|
set data [read $fd $bytes] |
||||||
|
} |
||||||
|
close $fd |
||||||
|
return $data |
||||||
|
} |
||||||
|
proc Get_HeaderSize {contents} { |
||||||
|
set 4bytes [split [string range $contents 0 3] ""] |
||||||
|
set hex4 "" |
||||||
|
foreach b [lreverse $4bytes] { |
||||||
|
set dec [scan $b %c] ;# 0-255 decimal |
||||||
|
set HH [format %2.2llX $dec] |
||||||
|
append hex4 $HH |
||||||
|
} |
||||||
|
return $hex4 |
||||||
|
} |
||||||
|
proc Get_LinkCLSID {contents} { |
||||||
|
set 16bytes [string range $contents 4 19] |
||||||
|
#CLSID hex textual representation is split as 4-2-2-2-6 bytes(hex pairs) |
||||||
|
#e.g We expect 00021401-0000-0000-C000-000000000046 for .lnk files |
||||||
|
#for endianness - it is little endian all the way but the split is 4-2-2-1-1-1-1-1-1-1-1 REVIEW |
||||||
|
#(so it can appear as mixed endianness if you don't know the splits) |
||||||
|
#https://devblogs.microsoft.com/oldnewthing/20220928-00/?p=107221 |
||||||
|
#This is based on COM textual representation of GUIDS |
||||||
|
#Apparently a CLSID is a GUID that identifies a COM object |
||||||
|
set clsid "" |
||||||
|
set s1 [tcl::string::range $16bytes 0 3] |
||||||
|
set declist [scan [string reverse $s1] %c%c%c%c] |
||||||
|
set fmt "%02X%02X%02X%02X" |
||||||
|
append clsid [format $fmt {*}$declist] |
||||||
|
|
||||||
|
append clsid - |
||||||
|
set s2 [tcl::string::range $16bytes 4 5] |
||||||
|
set declist [scan [string reverse $s2] %c%c] |
||||||
|
set fmt "%02X%02X" |
||||||
|
append clsid [format $fmt {*}$declist] |
||||||
|
|
||||||
|
append clsid - |
||||||
|
set s3 [tcl::string::range $16bytes 6 7] |
||||||
|
set declist [scan [string reverse $s3] %c%c] |
||||||
|
append clsid [format $fmt {*}$declist] |
||||||
|
|
||||||
|
append clsid - |
||||||
|
#now treat bytes individually - so no endianness conversion |
||||||
|
set declist [scan [tcl::string::range $16bytes 8 9] %c%c] |
||||||
|
append clsid [format $fmt {*}$declist] |
||||||
|
|
||||||
|
append clsid - |
||||||
|
set scan [string repeat %c 6] |
||||||
|
set fmt [string repeat %02X 6] |
||||||
|
set declist [scan [tcl::string::range $16bytes 10 15] $scan] |
||||||
|
append clsid [format $fmt {*}$declist] |
||||||
|
|
||||||
|
return $clsid |
||||||
|
} |
||||||
|
proc Contents_check_header {contents} { |
||||||
|
variable magic_HeaderSize |
||||||
|
variable magic_LinkCLSID |
||||||
|
expr {[Get_HeaderSize $contents] eq $magic_HeaderSize && [Get_LinkCLSID $contents] eq $magic_LinkCLSID} |
||||||
|
} |
||||||
|
|
||||||
|
#LinkFlags - 4 bytes - specifies information about the shell link and the presence of optional portions of the structure. |
||||||
|
proc Show_LinkFlags {contents} { |
||||||
|
set 4bytes [string range $contents 20 23] |
||||||
|
set r [binary scan $4bytes i val] ;# i for little endian 32-bit signed int |
||||||
|
puts "val: $val" |
||||||
|
set declist [scan [string reverse $4bytes] %c%c%c%c] |
||||||
|
set fmt [string repeat %08b 4] |
||||||
|
puts "LinkFlags:[format $fmt {*}$declist]" |
||||||
|
|
||||||
|
set r [binary scan $4bytes b32 val] |
||||||
|
puts "bscan-le: $val" |
||||||
|
set r [binary scan [string reverse $4bytes] b32 val] |
||||||
|
puts "bscan-2 : $val" |
||||||
|
} |
||||||
|
proc Get_LinkFlags {contents} { |
||||||
|
set 4bytes [string range $contents 20 23] |
||||||
|
set r [binary scan $4bytes i val] ;# i for little endian 32-bit signed int |
||||||
|
return $val |
||||||
|
} |
||||||
|
variable LinkFlags |
||||||
|
set LinkFlags [dict create\ |
||||||
|
hasLinkTargetIDList 1\ |
||||||
|
HasLinkInfo 2\ |
||||||
|
HasName 4\ |
||||||
|
HasRelativePath 8\ |
||||||
|
HasWorkingDir 16\ |
||||||
|
HasArguments 32\ |
||||||
|
HasIconLocation 64\ |
||||||
|
IsUnicode 128\ |
||||||
|
ForceNoLinkInfo 256\ |
||||||
|
HasExpString 512\ |
||||||
|
RunInSeparateProcess 1024\ |
||||||
|
Unused1 2048\ |
||||||
|
HasDarwinID 4096\ |
||||||
|
RunAsUser 8192\ |
||||||
|
HasExpIcon 16394\ |
||||||
|
NoPidlAlias 32768\ |
||||||
|
Unused2 65536\ |
||||||
|
RunWithShimLayer 131072\ |
||||||
|
ForceNoLinkTrack 262144\ |
||||||
|
EnableTargetMetadata 524288\ |
||||||
|
DisableLinkPathTracking 1048576\ |
||||||
|
DisableKnownFolderTracking 2097152\ |
||||||
|
DisableKnownFolderAlias 4194304\ |
||||||
|
AllowLinkToLink 8388608\ |
||||||
|
UnaliasOnSave 16777216\ |
||||||
|
PreferEnvironmentPath 33554432\ |
||||||
|
KeepLocalIDListForUNCTarget 67108864\ |
||||||
|
] |
||||||
|
variable LinkFlagLetters [list A B C D E F G H I J K L M N O P Q R S T U V W X Y Z AA] |
||||||
|
proc Has_LinkFlag {contents flagname} { |
||||||
|
variable LinkFlags |
||||||
|
variable LinkFlagLetters |
||||||
|
if {[string length $flagname] <= 2} { |
||||||
|
set idx [lsearch $LinkFlagLetters $flagname] |
||||||
|
if {$idx < 0} { |
||||||
|
error "punk::winlnk::Has_LinkFlag error - flagname $flagname not known" |
||||||
|
} |
||||||
|
set binflag [expr {2**$idx}] |
||||||
|
set allflags [Get_LinkFlags $contents] |
||||||
|
return [expr {$allflags & $binflag}] |
||||||
|
} |
||||||
|
if {[dict exists $LinkFlags $flagname]} { |
||||||
|
set binflag [dict get $LinkFlags $flagname] |
||||||
|
set allflags [Get_LinkFlags $contents] |
||||||
|
return [expr {$allflags & $binflag}] |
||||||
|
} else { |
||||||
|
error "punk::winlnk::Has_LinkFlag error - flagname $flagname not known" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#https://github.com/libyal/liblnk/blob/main/documentation/Windows%20Shortcut%20File%20(LNK)%20format.asciidoc |
||||||
|
|
||||||
|
#offset 24 4 bytes |
||||||
|
#File attribute flags |
||||||
|
|
||||||
|
#offset 28 8 bytes |
||||||
|
#creation date and time |
||||||
|
|
||||||
|
#offset 36 8 bytes |
||||||
|
#last access date and time |
||||||
|
|
||||||
|
#offset 44 8 bytes |
||||||
|
#last modification date and time |
||||||
|
|
||||||
|
#offset 52 4 bytes - unsigned int |
||||||
|
#file size in bytes (of target) |
||||||
|
proc Get_FileSize {contents} { |
||||||
|
set 4bytes [string range $contents 52 55] |
||||||
|
set r [binary scan $4bytes i val] |
||||||
|
return $val |
||||||
|
} |
||||||
|
|
||||||
|
#offset 56 4 bytes signed integer |
||||||
|
#icon index value |
||||||
|
|
||||||
|
#offset 60 4 bytes - unsigned integer |
||||||
|
#SW_SHOWNORMAL 0x00000001 |
||||||
|
#SW_SHOWMAXIMIZED 0x00000001 |
||||||
|
#SW_SHOWMINNOACTIVE 0x00000007 |
||||||
|
# - all other values MUST be treated as SW_SHOWNORMAL |
||||||
|
proc Get_ShowCommand {contents} { |
||||||
|
set 4bytes [string range $contents 60 63] |
||||||
|
set r [binary scan $4bytes i val] |
||||||
|
return $val |
||||||
|
} |
||||||
|
|
||||||
|
#offset 64 Bytes 2 |
||||||
|
#Hot key |
||||||
|
|
||||||
|
#offset 66 2 bytes - reserved |
||||||
|
|
||||||
|
#offset 68 4 bytes - reserved |
||||||
|
|
||||||
|
#offset 72 4 bytes - reserved |
||||||
|
|
||||||
|
#next 76 |
||||||
|
|
||||||
|
proc Get_LinkTargetIDList_size {contents} { |
||||||
|
if {[Has_LinkFlag $contents "A"]} { |
||||||
|
set 2bytes [string range $contents 76 77] |
||||||
|
set r [binary scan $2bytes s val] ;#short |
||||||
|
#logger |
||||||
|
#puts stderr "LinkTargetIDList_size: $val" |
||||||
|
return $val |
||||||
|
} else { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} |
||||||
|
proc Get_LinkInfo_content {contents} { |
||||||
|
set idlist_size [Get_LinkTargetIDList_size $contents] |
||||||
|
if {$idlist_size == 0} { |
||||||
|
set offset 0 |
||||||
|
} else { |
||||||
|
set offset [expr {2 + $idlist_size}] ;#LinkTargetIdList IDListSize field + value |
||||||
|
} |
||||||
|
set linkinfo_start [expr {76 + $offset}] |
||||||
|
if {[Has_LinkFlag $contents B]} { |
||||||
|
#puts stderr "linkinfo_start: $linkinfo_start" |
||||||
|
set 4bytes [string range $contents $linkinfo_start $linkinfo_start+3] |
||||||
|
binary scan $4bytes i val ;#size *including* these 4 bytes |
||||||
|
set linkinfo_content [string range $contents $linkinfo_start [expr {$linkinfo_start + $val -1}]] |
||||||
|
return [dict create linkinfo_start $linkinfo_start size $val next_start [expr {$linkinfo_start + $val}] content $linkinfo_content] |
||||||
|
} else { |
||||||
|
return [dict create linkinfo_start $linkinfo_start size 0 next_start $linkinfo_start content ""] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc LinkInfo_get_fields {linkinfocontent} { |
||||||
|
set 4bytes [string range $linkinfocontent 0 3] |
||||||
|
binary scan $4bytes i val ;#size *including* these 4 bytes |
||||||
|
set bytes_linkinfoheadersize [string range $linkinfocontent 4 7] |
||||||
|
set bytes_linkinfoflags [string range $linkinfocontent 8 11] |
||||||
|
set r [binary scan $4bytes i flags] ;# i for little endian 32-bit signed int |
||||||
|
#puts "linkinfoflags: $flags" |
||||||
|
|
||||||
|
set localbasepath "" |
||||||
|
set commonpathsuffix "" |
||||||
|
|
||||||
|
#REVIEW - flags problem? |
||||||
|
if {$flags & 1} { |
||||||
|
#VolumeIDAndLocalBasePath |
||||||
|
#logger |
||||||
|
#puts stderr "VolumeIDAndLocalBasePath" |
||||||
|
} |
||||||
|
if {$flags & 2} { |
||||||
|
#logger |
||||||
|
#puts stderr "CommonNetworkRelativeLinkAndPathSuffix" |
||||||
|
} |
||||||
|
set bytes_volumeid_offset [string range $linkinfocontent 12 15] |
||||||
|
set bytes_localbasepath_offset [string range $linkinfocontent 16 19] ;# a |
||||||
|
set bytes_commonnetworkrelativelinkoffset [string range $linkinfocontent 20 23] |
||||||
|
set bytes_commonpathsuffix_offset [string range $linkinfocontent 24 27] ;# a |
||||||
|
|
||||||
|
binary scan $bytes_localbasepath_offset i bp_offset |
||||||
|
if {$bp_offset > 0} { |
||||||
|
set tail [string range $linkinfocontent $bp_offset end] |
||||||
|
set stringterminator 0 |
||||||
|
set i 0 |
||||||
|
set localbasepath "" |
||||||
|
#TODO |
||||||
|
while {!$stringterminator & $i < 100} { |
||||||
|
set c [string index $tail $i] |
||||||
|
if {$c eq "\x00"} { |
||||||
|
set stringterminator 1 |
||||||
|
} else { |
||||||
|
append localbasepath $c |
||||||
|
} |
||||||
|
incr i |
||||||
|
} |
||||||
|
} |
||||||
|
binary scan $bytes_commonpathsuffix_offset i cps_offset |
||||||
|
if {$cps_offset > 0} { |
||||||
|
set tail [string range $linkinfocontent $cps_offset end] |
||||||
|
set stringterminator 0 |
||||||
|
set i 0 |
||||||
|
set commonpathsuffix "" |
||||||
|
#TODO |
||||||
|
while {!$stringterminator && $i < 100} { |
||||||
|
set c [string index $tail $i] |
||||||
|
if {$c eq "\x00"} { |
||||||
|
set stringterminator 1 |
||||||
|
} else { |
||||||
|
append commonpathsuffix $c |
||||||
|
} |
||||||
|
incr i |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
return [dict create localbasepath $localbasepath commonpathsuffix $commonpathsuffix] |
||||||
|
} |
||||||
|
|
||||||
|
proc contents_get_info {contents} { |
||||||
|
|
||||||
|
#todo - return something like the perl lnk-parse-1.0.pl script? |
||||||
|
|
||||||
|
#Link File: C:/repo/jn/tclmodules/tomlish/src/modules/test/#modpod-tomlish-0.1.0/suites/all/arrays_1.toml#roundtrip+roundtrip_files+arrays_1.toml.fauxlink.lnk |
||||||
|
#Link Flags: HAS SHELLIDLIST | POINTS TO FILE/DIR | NO DESCRIPTION | HAS RELATIVE PATH STRING | HAS WORKING DIRECTORY | NO CMD LINE ARGS | NO CUSTOM ICON | |
||||||
|
#File Attributes: ARCHIVE |
||||||
|
#Create Time: Sun Jul 14 2024 10:41:34 |
||||||
|
#Last Accessed time: Sat Sept 21 2024 02:46:10 |
||||||
|
#Last Modified Time: Tue Sept 10 2024 17:16:07 |
||||||
|
#Target Length: 479 |
||||||
|
#Icon Index: 0 |
||||||
|
#ShowWnd: 1 SW_NORMAL |
||||||
|
#HotKey: 0 |
||||||
|
#(App Path:) Remaining Path: repo\jn\tclmodules\tomlish\src\modules\test\#modpod-tomlish-0.1.0\suites\roundtrip\roundtrip_files\arrays_1.toml |
||||||
|
#Relative Path: ..\roundtrip\roundtrip_files\arrays_1.toml |
||||||
|
#Working Dir: C:\repo\jn\tclmodules\tomlish\src\modules\test\#modpod-tomlish-0.1.0\suites\roundtrip\roundtrip_files |
||||||
|
|
||||||
|
variable LinkFlags |
||||||
|
set flags_enabled [list] |
||||||
|
dict for {k v} $LinkFlags { |
||||||
|
if {[Has_LinkFlag $contents $k] > 0} { |
||||||
|
lappend flags_enabled $k |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set showcommand_val [Get_ShowCommand $contents] |
||||||
|
switch -- $showcommand_val { |
||||||
|
1 { |
||||||
|
set showwnd [list 1 SW_SHOWNORMAL] |
||||||
|
} |
||||||
|
3 { |
||||||
|
set showwnd [list 3 SW_SHOWMAXIMIZED] |
||||||
|
} |
||||||
|
7 { |
||||||
|
set showwnd [list 7 SW_SHOWMINNOACTIVE] |
||||||
|
} |
||||||
|
default { |
||||||
|
set showwnd [list $showcommand_val SW_SHOWNORMAL-effective] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set linkinfo_content_dict [Get_LinkInfo_content $contents] |
||||||
|
set localbase_path "" |
||||||
|
set suffix_path "" |
||||||
|
set linkinfocontent [dict get $linkinfo_content_dict content] |
||||||
|
set link_target "" |
||||||
|
if {$linkinfocontent ne ""} { |
||||||
|
set linkfields [LinkInfo_get_fields $linkinfocontent] |
||||||
|
set localbase_path [dict get $linkfields localbasepath] |
||||||
|
set suffix_path [dict get $linkfields commonpathsuffix] |
||||||
|
set link_target [file join $localbase_path $suffix_path] |
||||||
|
} |
||||||
|
|
||||||
|
set result [dict create\ |
||||||
|
link_target $link_target\ |
||||||
|
link_flags $flags_enabled\ |
||||||
|
file_attributes "<unimplemented>"\ |
||||||
|
create_time "<unimplemented>"\ |
||||||
|
last_accessed_time "<unimplemented"\ |
||||||
|
last_modified_time "<unimplementd>"\ |
||||||
|
target_length [Get_FileSize $contents]\ |
||||||
|
icon_index "<unimplemented>"\ |
||||||
|
showwnd "$showwnd"\ |
||||||
|
hotkey "<unimplemented>"\ |
||||||
|
relative_path "?"\ |
||||||
|
] |
||||||
|
} |
||||||
|
|
||||||
|
proc file_check_header {path} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun file_check_header] [arg path] ] |
||||||
|
#[para]Return 0|1 |
||||||
|
#[para]Determines if the .lnk file specified in path has a valid header for a windows shortcut |
||||||
|
set c [Get_contents $path 20] |
||||||
|
return [Contents_check_header $c] |
||||||
|
} |
||||||
|
proc file_get_info {path} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun file_get_info] [arg path] ] |
||||||
|
#[para] Return a dict of info obtained by parsing the binary data in a windows .lnk file |
||||||
|
#[para] If the .lnk header check fails, then the .lnk file probably isn't really a shortcut file and the dictionary will contain an 'error' key |
||||||
|
set c [Get_contents $path] |
||||||
|
if {[Contents_check_header $c]} { |
||||||
|
return [contents_get_info $c] |
||||||
|
} else { |
||||||
|
return [dict create error "lnk_header_check_failed"] |
||||||
|
} |
||||||
|
} |
||||||
|
proc file_show_info {path} { |
||||||
|
package require punk::lib |
||||||
|
punk::lib::showdict [file_get_info $path] * |
||||||
|
} |
||||||
|
|
||||||
|
#proc sample1 {p1 n args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
||||||
|
# #[para]Description of sample1 |
||||||
|
# #[para] Arguments: |
||||||
|
# # [list_begin arguments] |
||||||
|
# # [arg_def tring p1] A description of string argument p1. |
||||||
|
# # [arg_def integer n] A description of integer argument n. |
||||||
|
# # [list_end] |
||||||
|
# return "ok" |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::winlnk ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::winlnk::lib { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
tcl::namespace::path [tcl::namespace::parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::winlnk::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::winlnk::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
#tcl::namespace::eval punk::winlnk::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::winlnk::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::winlnk [tcl::namespace::eval punk::winlnk { |
||||||
|
variable pkg punk::winlnk |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
Binary file not shown.
Loading…
Reference in new issue