jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
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.
343 Commits
1 Branch
1 Tag
226 MiB
 
 
 
 
 
 
Tree: c5dc332e18
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from 'c5dc332e18'
${ noResults }
punkshell/src/modules/punk/winlnk-999999.0a1.0.tm

561 lines
20 KiB
Raw Blame History

# -*- 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]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# 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"
}
}
#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-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 {[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 999999.0a1.0
}]
return
#*** !doctools
#[manpage_end]