You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
836 lines
41 KiB
836 lines
41 KiB
# -*- tcl -*- |
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
|
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
|
# |
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# (C) 2024 |
|
# |
|
# @@ Meta Begin |
|
# Application punk::winlnk 999999.0a1.0 |
|
# Meta platform tcl |
|
# Meta license MIT |
|
# @@ Meta End |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# doctools header |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
#*** !doctools |
|
#[manpage_begin punkshell_module_punk::winlnk 0 999999.0a1.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 [lb]MS_SHLLINK[rb].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] |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# 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 Contents_check_header {contents} { |
|
variable magic_HeaderSize |
|
variable magic_LinkCLSID |
|
expr {[Header_Get_HeaderSize $contents] eq $magic_HeaderSize && [Header_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" |
|
} |
|
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 Header_Has_LinkFlag {contents flagname} { |
|
variable LinkFlags |
|
variable LinkFlagLetters |
|
if {[string length $flagname] <= 2} { |
|
set idx [lsearch $LinkFlagLetters $flagname] |
|
if {$idx < 0} { |
|
error "punk::winlnk::Header_Has_LinkFlag error - flagname $flagname not known" |
|
} |
|
set binflag [expr {2**$idx}] |
|
set allflags [Header_Get_LinkFlags $contents] |
|
return [expr {$allflags & $binflag}] |
|
} |
|
if {[dict exists $LinkFlags $flagname]} { |
|
set binflag [dict get $LinkFlags $flagname] |
|
set allflags [Header_Get_LinkFlags $contents] |
|
return [expr {$allflags & $binflag}] |
|
} else { |
|
error "punk::winlnk::Header_Has_LinkFlag error - flagname $flagname not known" |
|
} |
|
} |
|
|
|
#MS-SHLLINK.pdf documents the .lnk file format in detail, but here is a brief overview of the structure of a .lnk file: |
|
#protocol revision 10.0 (November 2025) https://winprotocoldocs-bhdugrdyduf5h2e4.b02.azurefd.net/MS-SHLLINK/%5bMS-SHLLINK%5d.pdf |
|
|
|
|
|
#SHELL_LINK_HEADER structure is 76 bytes long and starts at the beginning of the file |
|
#offset hex:0x00 dec:0 4 bytes |
|
#Header size (HeaderSize) (must be 0x0000004C for .lnk files) |
|
proc Header_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 |
|
} |
|
|
|
|
|
#offset hex:0x04 dec:4 16 bytes |
|
#LinkCLSID (must be 00021401-0000-0000-C000-000000000046 for .lnk files) |
|
proc Header_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 |
|
} |
|
|
|
|
|
#offset hex:0x14 dec:20 4 bytes |
|
#Link flags (LinkFlags) - bit field specifying information about the shell link and the presence of optional portions of the structure. |
|
#HasLinkTargetIDList bit 0 (0x00000001) - if set, a LinkTargetIDList structure is present immediately following the header |
|
#HasLinkInfo bit 1 (0x00000002) - if set, a LinkInfo structure is present immediately following the header (or the LinkTargetIDList if that is present) |
|
#HasName bit 2 (0x00000004) - if set, a null-terminated string containing the name of the link is present immediately following the header (or the LinkTargetIDList and LinkInfo if they are present) |
|
#HasRelativePath bit 3 (0x00000008) - if set, a null-terminated string containing the relative path of the link target is present immediately following the header (or the LinkTargetIDList, LinkInfo and Name if they are present) |
|
#HasWorkingDir bit 4 (0x00000010) - if set, a null-terminated string containing the working directory of the link target is present immediately following the header (or the LinkTargetIDList, LinkInfo, Name and Relative Path if they are present) |
|
#HasArguments bit 5 (0x00000020) - if set, a null-terminated string containing the command line arguments for the link target is present immediately following the header (or the LinkTargetIDList, LinkInfo, Name, Relative Path and Working Dir if they are present) |
|
#HasIconLocation bit 6 (0x00000040) - if set, a null-terminated string containing the location of the icon for the link is present immediately following the header (or the LinkTargetIDList, LinkInfo, Name, Relative Path, Working Dir and Arguments if they are present) |
|
#IsUnicode bit 7 (0x00000080) - if set, the strings in the link are stored in Unicode (UTF-16LE) format; if not set, the strings are stored in ANSI format (usually the system's default code page) |
|
#ForceNoLinkInfo bit 8 (0x00000100) - if set, the LinkInfo structure is not stored in the file even if the HasLinkInfo bit is set; this can be used to force the link to be resolved using only the information in the header and the optional strings, without using the LinkInfo structure |
|
#HasExpString bit 9 (0x00000200) - if set, a null-terminated string containing an "environment variable" style string is present immediately following the header (or the LinkTargetIDList, LinkInfo, Name, Relative Path, Working Dir, Arguments and Icon Location if they are present); this string can contain environment variable references (e.g. %USERPROFILE%) that can be expanded to obtain the actual path of the link target |
|
#RunInSeparateProcess bit 10 (0x00000400) - if set, the link target should be run in a separate process; if not set, the link target may be run in the same process as the caller |
|
#Unused1 bit 11 (0x00000800) - reserved for future use; should be set to 0 |
|
#HasDarwinID bit 12 (0x00001000) - if set, a null-terminated string containing a "Darwin ID" is present immediately following the header (or the LinkTargetIDList, LinkInfo, Name, Relative Path, Working Dir, Arguments, Icon Location and ExpString if they are present); this string can be used to identify the link target in a way that is independent of the file system (e.g. for links to Control Panel items or special folders) |
|
#RunAsUser bit 13 (0x00002000) - if set, the link target should be run with the permissions of the user specified in the HasDarwinID string; if not set, the link target should be run with the permissions of the caller |
|
#HasExpIcon bit 14 (0x00004000) - if set, a null-terminated string containing an "environment variable" style string for the icon location is present immediately following the header (or the LinkTargetIDList, LinkInfo, Name, Relative Path, Working Dir, Arguments, Icon Location, ExpString and DarwinID if they are present); this string can contain environment variable references that can be expanded to obtain the actual path of the icon for the link |
|
#NoPidlAlias bit 15 (0x00008000) - if set, the link target should not be resolved using the PIDL alias mechanism; this can be used to prevent the link from being resolved to a different target if the original target is moved or renamed |
|
#Unused2 bit 16 (0x00010000) - reserved for future use; should be set to 0 |
|
#RunWithShimLayer bit 17 (0x00020000) - if set, the link target should be run with the application compatibility shim layer; if not set, the link target should be run without the shim layer |
|
#ForceNoLinkTrack bit 18 (0x00040000) - if set, the link target should not be tracked by the shell's link tracking mechanism; this can be used to prevent the link from being automatically updated if the target is moved or renamed |
|
#EnableTargetMetadata bit 19 (0x00080000) - if set, the link target should have metadata enabled; this can be used to allow the link to store additional information about the target (e.g. for links to files, the link can store the file's attributes, creation time, access time and modification time) |
|
#DisableLinkPathTracking bit 20 (0x00100000) - if set, the link target should not be tracked by the shell's link path tracking mechanism; this can be used to prevent the link from being automatically updated if the target is moved or renamed based on its path |
|
#DisableKnownFolderTracking bit 21 (0x00200000) - if set, the link target should not be tracked by the shell's known folder tracking mechanism; this can be used to prevent the link from being automatically updated if the target is moved or renamed based on its known folder ID |
|
#DisableKnownFolderAlias bit 22 (0x00400000) - if set, the link target should not be aliased to a known folder; this can be used to prevent the link from being resolved to a different target if the original target is moved or renamed based on its known folder ID |
|
#AllowLinkToLink bit 23 (0x00800000) - if set, the link target can be another link; if not set, the link target should not be another link (i.e. it should be a file or directory); this can be used to prevent the link from being resolved to a different target if the original target is moved or renamed based on the fact that it is a link |
|
#UnaliasOnSave bit 24 (0x01000000) - if set, the link should be unaliased when it is saved; this can be used to prevent the link from being resolved to a different target if the original target is moved or renamed based on the fact that it is a link |
|
#PreferEnvironmentPath bit 25 (0x02000000) - if set, the link should prefer to resolve the target using environment variable references; this can be used to allow the link to be resolved correctly even if the target is moved or renamed, as long as the environment variable references still point to the correct location |
|
#KeepLocalIDListForUNCTarget bit 26 (0x04000000) - if set, the link should keep the local ID list for UNC targets; this can be used to allow the link to be resolved correctly even if the target is moved or renamed, as long as the local ID list still points to the correct location |
|
# - the presence of these flags indicates the presence of optional structures in the .lnk file and also provides information about how to interpret the data in the file |
|
proc Header_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 |
|
} |
|
|
|
#offset hex:0x18 dec:24 4 bytes |
|
#File attributes (FileAttributes) - bit field specifying the file attributes of the link target (if the EnableTargetMetadata flag is set in the LinkFlags field); this field is a bitwise combination of the following values: |
|
proc Header_Get_FileAttributes {contents} { |
|
if {![Header_Has_LinkFlag $contents "EnableTargetMetadata"]} { |
|
return {} |
|
} |
|
set 4bytes [string range $contents 24 27] |
|
set r [binary scan $4bytes i val] ;# i for little endian 32-bit signed int |
|
set attrlist {} |
|
if {$val & 0x00000001} {lappend attrlist "READONLY"} |
|
if {$val & 0x00000002} {lappend attrlist "HIDDEN"} |
|
if {$val & 0x00000004} {lappend attrlist "SYSTEM"} |
|
if {$val & 0x00000010} {lappend attrlist "DIRECTORY"} |
|
if {$val & 0x00000020} {lappend attrlist "ARCHIVE"} |
|
if {$val & 0x00000040} {lappend attrlist "DEVICE"} |
|
if {$val & 0x00000080} {lappend attrlist "NORMAL"} |
|
if {$val & 0x00000100} {lappend attrlist "TEMPORARY"} |
|
if {$val & 0x00000200} {lappend attrlist "SPARSE_FILE"} |
|
if {$val & 0x00000400} {lappend attrlist "REPARSE_POINT"} |
|
if {$val & 0x00000800} {lappend attrlist "COMPRESSED"} |
|
if {$val & 0x00001000} {lappend attrlist "OFFLINE"} |
|
if {$val & 0x00002000} {lappend attrlist "NOT_CONTENT_INDEXED"} |
|
if {$val & 0x00004000} {lappend attrlist "ENCRYPTED"} |
|
return $attrlist |
|
} |
|
proc Header_Get_FileAttributes_Raw {contents} { |
|
if {![Header_Has_LinkFlag $contents "EnableTargetMetadata"]} { |
|
return 0 |
|
} |
|
set 4bytes [string range $contents 24 27] |
|
set r [binary scan $4bytes i val] ;# i for little endian 32-bit signed int |
|
return $val |
|
} |
|
|
|
|
|
|
|
|
|
#offset hex:0x1C dec:28 8 bytes |
|
#creation date and time (CreationTime) (FILETIME structure - 64-bit value representing the number of 100-nanosecond intervals since January 1, 1601 (UTC)) |
|
proc Header_Get_CreationTime {contents} { |
|
set 8bytes [string range $contents 28 35] |
|
set r [binary scan $8bytes w val] ;# w for little endian 64-bit signed int |
|
#convert FILETIME to human readable format - this is a bit complex because FILETIME is in 100-nanosecond intervals since January 1, 1601 (UTC) |
|
#we can convert it to seconds and then to a human readable format |
|
set seconds [expr {$val / 10000000.0}] |
|
set epoch_seconds [expr {round($seconds) - 11644473600}] ;# number of seconds between January 1, 1601 and January 1, 1970 |
|
set human_time [clock format $epoch_seconds -format "%Y-%m-%d %H:%M:%S" -gmt true] |
|
return $human_time |
|
} |
|
proc Header_Get_CreationTime_Raw {contents} { |
|
set 8bytes [string range $contents 28 35] |
|
set r [binary scan $8bytes w val] ;# w for little endian 64-bit signed int |
|
return $val |
|
} |
|
|
|
#offset 36 8 bytes |
|
#last access date and time (AccessTime) (FILETIME structure - 64-bit value representing the number of 100-nanosecond intervals since January 1, 1601 (UTC)) |
|
proc Header_Get_AccessTime {contents} { |
|
set 8bytes [string range $contents 36 43] |
|
set r [binary scan $8bytes w val] ;# w for little endian 64-bit signed int |
|
#convert FILETIME to human readable format - this is a bit complex because FILETIME is in 100-nanosecond intervals since January 1, 1601 (UTC) |
|
#we can convert it to seconds and then to a human readable format |
|
set seconds [expr {$val / 10000000.0}] |
|
set epoch_seconds [expr {round($seconds) - 11644473600}] ;# number of seconds between January 1, 1601 and January 1, 1970 |
|
set human_time [clock format $epoch_seconds -format "%Y-%m-%d %H:%M:%S" -gmt true] |
|
return $human_time |
|
} |
|
proc Header_Get_AccessTime_Raw {contents} { |
|
set 8bytes [string range $contents 36 43] |
|
set r [binary scan $8bytes w val] ;# w for little endian 64-bit signed int |
|
return $val |
|
} |
|
|
|
#offset hex:0x2C dec:44 8 bytes |
|
#last modification date and time (WriteTime) (FILETIME structure - 64-bit value representing the number of 100-nanosecond intervals since January 1, 1601 (UTC)) |
|
proc Header_Get_WriteTime {contents} { |
|
set 8bytes [string range $contents 44 51] |
|
set r [binary scan $8bytes w val] ;# w for little endian 64-bit signed int |
|
#convert FILETIME to human readable format - this is a bit complex because FILETIME is in 100-nanosecond intervals since January 1, 1601 (UTC) |
|
#we can convert it to seconds and then to a human readable format |
|
set seconds [expr {$val / 10000000.0}] |
|
set epoch_seconds [expr {round($seconds) - 11644473600}] ;# number of seconds between January 1, 1601 and January 1, 1970 |
|
set human_time [clock format $epoch_seconds -format "%Y-%m-%d %H:%M:%S" -gmt true] |
|
return $human_time |
|
} |
|
proc Header_Get_WriteTime_Raw {contents} { |
|
set 8bytes [string range $contents 44 51] |
|
set r [binary scan $8bytes w val] ;# w for little endian 64-bit signed int |
|
return $val |
|
} |
|
|
|
#offset hex:0x34 dec:52 Bytes:4 - unsigned int |
|
#file size in bytes (of target - low 32 bits if >4GB) |
|
proc Header_Get_FileSize {contents} { |
|
set 4bytes [string range $contents 52 55] |
|
set r [binary scan $4bytes i val] |
|
return $val |
|
} |
|
|
|
#offset hex:0x38 dec:56 Bytes:4 - signed integer |
|
#icon index value |
|
proc Header_Get_IconIndex {contents} { |
|
set 4bytes [string range $contents 56 59] |
|
set r [binary scan $4bytes i val] |
|
return $val |
|
} |
|
|
|
#offset hex:0x3C dec:60 Bytes:4 - unsigned integer |
|
#SW_SHOWNORMAL 0x00000001 |
|
#SW_SHOWMAXIMIZED 0x00000001 |
|
#SW_SHOWMINNOACTIVE 0x00000007 |
|
# - all other values MUST be treated as SW_SHOWNORMAL |
|
proc Header_Get_ShowCommand {contents} { |
|
set 4bytes [string range $contents 60 63] |
|
set r [binary scan $4bytes i val] |
|
return $val |
|
} |
|
|
|
#offset hex:0x40 dec:64 Bytes:2 |
|
#Hot key |
|
proc Header_Get_HotKey {contents} { |
|
# Existing code that extracts the raw 16‑bit hotkey value: |
|
set raw [Header_Get_HotKey_Raw $contents] |
|
# The low byte holds the virtual‑key, high byte holds modifier flags |
|
set vk [expr {$raw & 0xFF}] |
|
set mods [expr {($raw >> 8) & 0xFF}] |
|
set name [_vk_to_name $vk] |
|
set modStr [_modifiers_to_string $mods] |
|
if {$modStr eq ""} { |
|
return $name |
|
} else { |
|
return "${modStr}+${name}" |
|
} |
|
} |
|
proc Header_Get_HotKey_Raw {contents} { |
|
set 2bytes [string range $contents 64 65] |
|
set r [binary scan $2bytes s val] ;#short |
|
return $val |
|
} |
|
proc _modifiers_to_string {mods} { |
|
set parts {} |
|
if {$mods & 0x01} {lappend parts "Shift"} |
|
if {$mods & 0x02} {lappend parts "Ctrl"} |
|
if {$mods & 0x04} {lappend parts "Alt"} |
|
if {$mods & 0x08} {lappend parts "Win"} ;# optional |
|
return [join $parts "+"] |
|
} |
|
proc _vk_to_name {vk} { |
|
# Minimal map – extend as needed |
|
array set vkMap { |
|
0x00 "No key assigned" |
|
0x08 Backspace 0x09 Tab 0x0D Return |
|
0x10 Shift 0x11 Control 0x12 Alt |
|
0x20 Space 0x21 PageUp 0x22 PageDown |
|
0x23 End 0x24 Home 0x25 Left |
|
0x26 Up 0x27 Right 0x28 Down |
|
0x2D Insert 0x2E Delete |
|
0x70 F1 0x71 F2 0x72 F3 |
|
0x73 F4 0x74 F5 0x75 F6 |
|
0x76 F7 0x77 F8 0x78 F9 |
|
0x79 F10 0x7A F11 0x7B F12 |
|
0x7c F13 0x7d F14 0x7e F15 |
|
0x7f F16 0x80 F17 0x81 F18 |
|
0x82 F19 0x83 F20 0x84 F21 |
|
0x85 F22 0x86 F23 0x87 F24 |
|
0x90 "NUM LOCK" 0x91 "SCROLL LOCK" |
|
} |
|
if {[info exists vkMap($vk)]} { |
|
return $vkMap($vk) |
|
} else { |
|
if {$vk >= 0x30 && $vk <= 0x39} { |
|
return [format "%c" $vk] ;# 0-9 |
|
} elseif {$vk >= 0x41 && $vk <= 0x5A} { |
|
return [format "%c" $vk] ;# A-Z |
|
} |
|
# fallback: hex representation |
|
return [format "0x%02X" $vk] |
|
} |
|
} |
|
|
|
#offset hex:0x42 dec:66 Bytes:2 - reserved1 |
|
proc Header_Get_Reserved1 {contents} { |
|
set 2bytes [string range $contents 66 67] |
|
set r [binary scan $2bytes s val] ;#short |
|
return $val |
|
} |
|
|
|
#offset hex:0x44 dec:68 Bytes:4 - reserved2 |
|
proc Header_Get_Reserved2 {contents} { |
|
set 4bytes [string range $contents 68 71] |
|
set r [binary scan $4bytes i val] ;# i for little endian 32-bit signed int |
|
return $val |
|
} |
|
|
|
#offset hex:0x48 dec:72 Bytes:4 - reserved3 |
|
proc Header_Get_Reserved3 {contents} { |
|
set 4bytes [string range $contents 72 75] |
|
set r [binary scan $4bytes i val] ;# i for little endian 32-bit signed int |
|
return $val |
|
} |
|
|
|
#end of 76 byte header |
|
|
|
proc Get_LinkTargetIDList_size {contents} { |
|
if {[Header_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 {[Header_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-999999.0a1.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-999999.0a1.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-999999.0a1.0\suites\roundtrip\roundtrip_files |
|
|
|
variable LinkFlags |
|
set flags_enabled [list] |
|
dict for {k v} $LinkFlags { |
|
if {[Header_Has_LinkFlag $contents $k] > 0} { |
|
lappend flags_enabled $k |
|
} |
|
} |
|
|
|
set showcommand_val [Header_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] |
|
if {"windows" eq $::tcl_platform(platform)} { |
|
set link_target [file join $localbase_path $suffix_path] |
|
} else { |
|
set suffix_path [string map {\\ /} $suffix_path] |
|
if {[regexp {([a-zA-Z]):\\(.*)} $localbase_path _match drive_letter tail]} { |
|
set localbase_path [string map {\\ /} $localbase_path] |
|
set tail [string map {\\ /} $tail] |
|
set link_target "" |
|
#shortcut basepath is a windows path with drive letter - try to resolve it on unix by looking for a corresponding mount from fstab or a point under /mnt |
|
set mountinfo [exec mount] |
|
foreach line [split $mountinfo "\n"] { |
|
#review - a more specific mount target might exist that includes the drive letter as part of the mount point name and is a longer prefix of the localbase_path |
|
#- we should probably look for the longest prefix match rather than just the drive letter |
|
if {[regexp -nocase -- [string cat ^$drive_letter {:\\\s+on\s+(\S)}] $line _match mount_point]} { |
|
set link_target [file join $mount_point $tail $suffix_path] |
|
break |
|
} |
|
} |
|
if {$link_target eq ""} { |
|
#review - under what circumstances could this happen? If the drive letter doesn't match any mount points, then /mnt/drive_letter should generally already have been found above above |
|
# - However, it may be possible for /mnt/drive_Letter to still exist even if it's not reflected in the output of mount or the output of mount is in an unexpected format. |
|
|
|
#nothing in mount result matches the drive letter - try looking for a mount point under /mnt with the drive letter as the name |
|
if {[file exists /mnt/$drive_letter]} { |
|
set link_target [file join /mnt/$drive_letter $tail $suffix_path] |
|
} else { |
|
if {$drive_letter eq [string tolower $drive_letter]]} { |
|
set op_drive_letter [string toupper $drive_letter] |
|
} else { |
|
set op_drive_letter [string tolower $drive_letter] |
|
} |
|
if {[file exists /mnt/$op_drive_letter]} { |
|
set link_target [file join /mnt/$op_drive_letter $tail $suffix_path] |
|
} else { |
|
#leave as is except for backslashes converted to forward |
|
#- probably won't resolve correctly unless the unix system has a folder named drive_letter: in the current folder with a copy of the original filestructure. |
|
set link_target [file join $localbase_path $suffix_path] |
|
} |
|
} |
|
} else { |
|
#shortcut basepath is a windows path with drive letter and we found a matching mount point - link_target is set to the resolved path |
|
} |
|
} else { |
|
#shortcut basepath doesn't match expected windows path format - just join it with the suffix and hope for the best |
|
#could be something like a network path or it could be something else entirely |
|
set link_target [file join $localbase_path $suffix_path] |
|
} |
|
} |
|
} |
|
|
|
set result [dict create\ |
|
link_target $link_target\ |
|
link_flags $flags_enabled\ |
|
file_attributes [Header_Get_FileAttributes $contents]\ |
|
creation_time [Header_Get_CreationTime $contents]\ |
|
access_time [Header_Get_AccessTime $contents]\ |
|
write_time [Header_Get_WriteTime $contents]\ |
|
target_length [Header_Get_FileSize $contents]\ |
|
icon_index "<unimplemented>"\ |
|
showwnd "$showwnd"\ |
|
hotkey [Header_Get_HotKey $contents]\ |
|
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] |
|
} |
|
namespace eval argdoc { |
|
variable PUNKARGS |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::winlnk::resolve |
|
@cmd -name punk::winlnk::resolve\ |
|
-summary\ |
|
"Return information about a .lnk file (windows shortcut)"\ |
|
-help\ |
|
"Return a dict of info obtained by parsing the binary data in a windows .lnk file. |
|
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." |
|
@values -min 1 -max 1 |
|
path -type string -help "Path to the .lnk file to resolve" |
|
}] |
|
} |
|
proc resolve {path} { |
|
#*** !doctools |
|
#[call [fun resolve] [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"] |
|
} |
|
} |
|
namespace eval argdoc { |
|
variable PUNKARGS |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::winlnk::file_show_info |
|
@cmd -name punk::winlnk::file_show_info\ |
|
-summary\ |
|
"Show information about a .lnk file (windows shortcut)"\ |
|
-help\ |
|
"Print to stdout the information obtained by parsing the binary data in a windows .lnk file, in a human readable format. |
|
If the .lnk header check fails, then the .lnk file probably isn't really a shortcut file and an error message will be printed." |
|
@values -min 1 -max 1 |
|
path -type string -help "Path to the .lnk file to resolve" |
|
}] |
|
} |
|
proc file_show_info {path} { |
|
package require punk::lib |
|
punk::lib::showdict [resolve $path] * |
|
} |
|
namespace eval argdoc { |
|
variable PUNKARGS |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::winlnk::target |
|
@cmd -name punk::winlnk::target\ |
|
-summary\ |
|
"Return the target path of a .lnk file (windows shortcut)"\ |
|
-help\ |
|
"Return the target path of the .lnk file specified in path. |
|
This is a convenience function that extracts the target path from the .lnk file and returns it directly, |
|
without all the additional information that resolve provides. If the .lnk header check fails, then |
|
the .lnk file probably isn't really a shortcut file and an error message will be returned." |
|
@values -min 1 -max 1 |
|
path -type string -help "Path to the .lnk file to resolve" |
|
}] |
|
} |
|
proc target {path} { |
|
#*** !doctools |
|
#[call [fun target] [arg path] ] |
|
#[para]Return the target path of the .lnk file specified in path |
|
set info [resolve $path] |
|
if {[dict exists $info error]} { |
|
return [dict get $info error] |
|
} else { |
|
return [dict get $info link_target] |
|
} |
|
} |
|
|
|
#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 |
|
|
|
|
|
|
|
#} |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
namespace eval ::punk::args::register { |
|
#use fully qualified so 8.6 doesn't find existing var in global namespace |
|
lappend ::punk::args::register::NAMESPACES ::punk::winlnk |
|
} |
|
## Ready |
|
package provide punk::winlnk [tcl::namespace::eval punk::winlnk { |
|
variable pkg punk::winlnk |
|
variable version |
|
set version 999999.0a1.0 |
|
}] |
|
return |
|
|
|
#*** !doctools |
|
#[manpage_end] |
|
|
|
|