Can Tcl manage Windows "shell links" [L1 ]? Certainly; there are at least six ways:
dde execute progman progman "" "\[CreateGroup(Bogus)\]" dde execute progman progman "" \ "\[AddItem(notepad.exe,BogusPadLink)\]" dde execute progman progman "" "\[ShowGroup(Bogus,0)\]" dde execute progman progman "" "\[ShowGroup(Bogus,1)\]" dde execute progman progman "" "\[DeleteItem(BogusPadLink)\]" dde execute progman progman "" "\[DeleteGroup(Bogus)\]"
A ZIP file containing a PDF with detailed information on the link file format [L6 ]
RS tried reading such links, or "shortcuts", in a simpler, and pure-Tcl way. If you look at .lnk files in hexdump, you notice that they contain the string of what they link to, among other things. So I tried just to split on NUL bytes and see whether a snippet is a valid absolute path:
proc readlnk {lnk} { set res "" set fp [open $lnk] foreach snip [split [read $fp] \x00] { if {[regexp {[A-Z]:\\} $snip] && [file exists $snip]} { lappend res $snip } } close $fp join $res }
This is highly experimental, but it worked on the few examples I tried - please correct me if you know better! Simple links to directories and files work. Links that contain an executable invocation with arguments and icon, are a funny mix of ASCII and Unicode, so splitting on 0 is not a good idea there, and the above code does not work.
See also Symbolic links in Windows/CE
package require tcom set sh [::tcom::ref createobject "WScript.Shell"] set lnk [$sh CreateShortcut {D:\WORK\Acrobat.lnk}] $lnk TargetPath {"D:\Program Files\Adobe\Acrobat 4.0\Acrobat\Acrobat.exe"} $lnk WorkingDirectory {D:\WORK} $lnk Arguments Tutorial.pdf $lnk Save
AF - here is a code snippet i wrote to parse .lnk files. i lost interest when i found out how complex the format was and that i would never be able to write them.
array set sizeof [list a 1 A 1 b 1 B 1 h 1 H 1 c 1 s 2 S 2 i 4 I 4 w 8 W 8] proc getdword {fh} { binary scan [read $fh 4] i tmp return $tmp } proc getword {fh} { binary scan [read $fh 2] s tmp return $tmp } proc struct {name defs} { global struct_sizes struct_defs set offset 0 set tmp {} foreach {type n} $defs { set type [string trim $type] set n [string trim $n] if {[string match string* $type]} { set len [lindex [split $type {[]}] 1] set type string } else { if {![info exists struct_sizes($type)]} { error "unknown type" } set len $struct_sizes($type) } lappend tmp [list $n $offset $type $len] incr offset $len } set struct_defs($name) [linsert $tmp 0 $offset] } proc _islnk {fh} { fconfigure $fh -encoding binary -translation binary -eofchar {} if {[getdword $fh] != "76"} { close $fh; return -code error "not a lnk file" } binary scan [read $fh 16] h32 tmp if {$tmp != "10412000000000000c00000000000064"} { close $fh; return -code error "unrecognized GUID" } return $fh } proc readlnk {lnk} { array set array {} set fh [_islnk [open $lnk r]] set array(flags) [getdword $fh] set attributes [read $fh 4] struct $fh * array(created) w array(modified) w array(acessed) w array(size) i array(icon) i array(showwnd) i array(hotkey) i res1 i res2 i if {$array(flags) & 1 > 0} { set len [getword $fh] set w1 [walkStart $fh s *] while {![walkDone $w1]} { puts [walkNext $w1] } walkEnd $w1 } set offset [tell $fh] set structlen [getdword $fh] if {$array(flags) & 2 > 0 && $structlen > 0} { struct $fh * nextstruct i flflags i lvt i lvbp i nvt i path i set nextstruct [expr {[tell $fh] + $structlen - $nextstruct}] if {($flflags & 1) > 0} { seek $fh [expr {$offset + $lvt}] start struct $fh [expr {[getdword $fh] - 4}] type i serial i noff i name a* seek $fh [expr {$offset + $lvbp}] start set base [read $fh [expr {$offset + $structlen - [tell $fh]}]] } if {($flflags & 2) > 0} { seek $fh [expr {$offset + $nvt}] start struct $fh [expr {[getdword $fh] - 4}] a i b i c i d i base a* } seek $fh [expr {$offset + $path}] start set path [read $fh [expr {$nextstruct - [tell $fh]}]] seek $fh $nextstruct start } set array(base) [string trimright $base \x00] set array(final) [string trimright $path \x00] set f 4 foreach name "comment relativepath workingdir commandline icon" { if {($array(flags) & $f) > 0} { set len [getword $fh] set array($name) [read $fh [expr {$len * 2}]] } set f [expr {$f * 2}] } return [array get array] } array set blah [readlnk $argv] parray blah if {$blah(final) == ""} { puts "--> $blah(base)" } else { puts "--> $blah(base)\\$blah(final)" }
Another simple way, if you have Cygwin (RS):
exec ln -s /path/to/this/file that
Related information appears in "Windows specific Tcl commands". Microsoft Windows and Tcl - Arts and crafts of Tcl-Tk programming