Version 10 of Windows shell links

Can Tcl manage Windows "shell links" [L1 ]? Certainly; there are at least six ways:

Matt Newman's tlink32 [L2 ]
by way of DDE, as David Gravereaux exemplifies:

      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)\]"

Steve Cassidy wraps this DDE approach in a progman.tcl [L3 ] package designed "package to allow creation of program groups and shortcuts in the start menu on Windows 9x/NT"
Bill Schongar's WISE hack [L4 ]
freeWrap includes "shell link" functionality comparable to tlink32's.
NT-TCL [L5 ] includes a shortcut.dll that although ancient works with recent version of Tcl thanks to the stubs interface. Can't seem to find the source though.
[...]

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

NJG

 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)"
 }