# -*- tcl -*- 
#
# This code decodes the windows .lnk file.  It provides several bits of
# information about the link as defined below.
#
# Our interface:
# Return value is 1 if "filename" is a lnk file. 
# Otherwise 0 (includes unreadable not a filename, etc.)
# If 0 is returned and "to" is provided, "to" will be set to a reason.
# "to" if provided is a var that will be set to the file the link points to.
# "dir" if provided will be set to 1 if the link points at a directory, else 0.
# "try" if 1, will attempt to decode even if the "required fields" are wrong.
#       The required fields are "header length == 72" and "clid is correct"
# "diag" Causes debug info to be spilled out to stdout

# This code was written with reference to MS document: [MS_SHLLINK]

proc setTo {to this} {
  if {$to != {}} {
    uplevel 2 "set $to \"$this\""
  }
}
# LnkFile filename
# This version returns the path or the file name (if not a lnk)
# Returns error if a link but not to a file or file is missing


proc LnkFile {filename} {
  if {[LnkFileOld $filename to] == 1} {
    if {[file exists $to]} {return $to}
    return $filename
  }
  if {[string match "Not link file*" $to]} {
    return $filename
  }
  error $to
}

proc LnkFileOld { filename {to {}} {dir {}} {try 0} {diag 0}} {

  # The first structure is the "ShellLinkHeader" which has a fixed size (0x4c or 73)
  # in the first 4-byte word. This contains the "LinkCLSID" (16-bytes) that must be
  # "00021401-0000-0000-C000-000000000046" (see page 9). Also note, all of MSW is
  # little-endian.
  # Constants of interest...
  # set headerlength 72  # 0x4c
  # set clid0 [expr {0x21401}]
  # set clid1 0
  # set clid2 [expr { 0xc0}]
  # set clid3 [expr { 0x46000000 }]
  # After the "LinkCLSID" is the "linkFlags" 4-bytes. The bits of interest are...
  # linkflags bits ... (pages 10-12)
   set HasLinkTargetIDList 1
   set HasLinkInfo         2
   set Name                4
   set RelativePath        8
   set WorkingDir         16
   set Arguments          32
   set IconLocation       64
   set IsUniCode         128
   set IgnorLinkInfo     256
   set HasExpString      512
   set PreferEnvPath    0x2000000
   # All we are intested in here...
   # Then comes the "FileAttributesFlags". We are only interested in the Is a Directory.
   # FileAttributesFlags ....
   # set ReadOnly            1
   # set Hidden              2
   # set System              4
   set Directory            16  
   # set Archive            32  # 0x20
   # set Normal            128  # 0x80

   # first we want to be sure that it really is a .lnk file...
   # we don't trust, or even test, the suffix, but rather use the
   # internal info in the file.
   if { ! [file exists $filename] ||\
	    ! [file readable $filename] ||\
	    [file isdirectory $filename]} {
     frputs "LnkFile no such file or not readable or dir " filename
     setTo $to "no such file ($filename) or not readable or dir"
     return 0
   }
   set f [OpenBinaryFile $filename]
   #  chan seek $f
   set len [BinaryRead 4 $f]
   if { $len != 0x4c && ! $try} {
     frputs "LnkFile Not link file, header length $len, not 76  " filename
     setTo to "Not link file, header length $len, not 76"
     close $f
     return 0
   }
   set clid0 [BinaryRead 4 $f]
   set clid1 [BinaryRead 4 $f]
   set clid2 [BinaryRead 4 $f]
   set clid3 [BinaryRead 4 $f]
   if { ($clid0 != 0x21401 || $clid1 != 0 || \
	     $clid2 != 0xc0 || $clid3 != 0x46000000) && ! $try } {
     frputs "LnkFile Not a link file, CLID is bad  " filename
     setTo $to "Not a link file, CLID is bad"
     close $f
     return 0  
   }

   set linkflags [BinaryRead 4 $f]
   set attrib  [BinaryRead 4 $f]
   # We are not interested in the rest of the header, seek to the next
   # block...
   PutsHex linkflags
   PutsHex attrib
   set IsDir [expr {($attrib & $Directory) != 0?1:0}]
   setTo $dir $IsDir

   # Life should be so easy, push onward...

   chan seek $f 76 start

   # Here we find optional fields in this order 
   # LinkTarget_IDList, LinkInfo, StringData

   # LinkTarget_IDList... There may be more than one item
   if { $linkflags & $HasLinkTargetIDList } {
     set Start_of_TargetID [chan tell $f]
     # ListStze is the total list size, use it to get to the next entry
     set ListSize  [BinaryRead 2 $f]
     PutsHex Start_of_TargetID
     PutsHex ListSize
     # # Here is an array of IDList things with the first 2-bytes indicating the
     # # length which includes the length itself (zero is the terminal)
     # set count 0
     # while {[set subIdSize [BinaryRead 2 $f]] != 0 && [incr subIdLimit] < 20} {
     #   set TargetId$count [chan read $f $subIdSize]
     #   PutsString TargetId$count
     #   incr count
     # }
     # The "ListSize" does not include itself, so add 2
     chan seek $f  [expr {$ListSize + $Start_of_TargetID + 2} ] start
     
     #       puts "LinkTarget_IDList $ListSize >$ListInfo<"


     set End_of_TargetID [chan tell $f]
     PutsHex End_of_TargetID
     #    set IDindex 0
     #   while { [set IDsize [BinaryRead 2 $f]] > 0 } {
     #      set IDarray([incr IDindex]) [chan read $f [incr $IDsize -2]]
     #    }
     #   puts "Found $IDindex structures skipped"
     #    while { $IDindex > 0 } {
     #      puts "$IDarray($IDindex)"
     #      incr IDindex -1
     #    }
   }
   # LinkInfo  Finally getting to the meat of it...
   if { $linkflags & $HasLinkInfo } {
     set LinkInfoOffset [chan tell $f]
     set LinkInfoSize [BinaryRead 4 $f]
     set LinkInfoHeaderSize [BinaryRead 4 $f]
     set LinkInfoFlags [BinaryRead 4 $f]
     set LinkInfoVolIDOffset [BinaryRead 4 $f]
     
     set LinkInfoLocalBasePathOffset [BinaryRead 4 $f]
     set LinkInfoCommonNetworkOffset [BinaryRead 4 $f]
     set LinkInfoCommonPathSuffixOffset [BinaryRead 4 $f]
     if { $LinkInfoHeaderSize != 0x1c } {
       set LinkInfoLocalBasePathOffsetUcd [BinaryRead 4 $f]
       set LinkInfoCommonPathSuffixOffsetUcd [BinaryRead 4 $f]
     } else {
       set LinkInfoLocalBasePathOffsetUcd 0
       set LinkInfoCommonPathSuffixOffsetUcd 0
     }
     #     puts "$linkflags $HasLinkInfo "
     PutsHex LinkInfoOffset
     PutsHex LinkInfoSize
     PutsHex LinkInfoHeaderSize
     PutsHex LinkInfoFlags
     PutsHex LinkInfoVolIDOffset
     PutsHex LinkInfoLocalBasePathOffset
     PutsHex LinkInfoCommonNetworkOffset
     PutsHex LinkInfoCommonPathSuffixOffset
     PutsHex LinkInfoLocalBasePathOffsetUcd
     PutsHex LinkInfoCommonPathSuffixOffsetUcd

     # Ok, lets get the Volume info... if it exists
     if { $LinkInfoVolIDOffset != 0 } {
       chan seek $f [set VolIdOffset \
			 [expr {$LinkInfoVolIDOffset + $LinkInfoOffset} ]]
       PutsHex VolIdOffset
       set VolIDSize [BinaryRead 4 $f]
       set DriveType  [BinaryRead 4 $f]
       set DriveType [switch  $DriveType { 
	 0 {expr {{UnKnown}}}
	 1 {expr {{No_Root_Dir}}}
	 2 {expr {{Removable}}}
	 3 {expr {{Fixed}}}
	 4 {expr {{Remote}}}
	 5 {expr {{CDROM}}}
	 6 {expr {{RamDisk}}}
       } ]
       PutsString DriveType
       set DriveSerial [BinaryRead 4 $f]
       PutsHex DriveSerial
       set VolLabelOffset  [BinaryRead 4 $f]
       if { $VolLabelOffset == 0x14 } {
	 
	      set VolLabelOffset  [BinaryRead 4 $f]

	      set VolIsUcode 1
	    } else {
	      set VolIsUcode 0
	    }
       PutsHex VolLabelOffset
       PutsHex VolIsUcode
       if { $VolIsUcode == 0 } {
	      set VolIdString [GetNullTermString $f \
				   [expr { $VolIdOffset + $VolLabelOffset } ]]
       } else {
	      set VolIdString [GetNullTermStringUnc $f \
				   [expr { $VolIdOffset + $VolLabelOffset } ]]
       }
       PutsString VolIdString
     }
     # Here we get the Local Base string
     if { $LinkInfoLocalBasePathOffset != 0 } {
       set BasePath [GetNullTermString $f \
			 [expr {$LinkInfoLocalBasePathOffset + \
				    $LinkInfoOffset } ]]
       PutsString BasePath
     }
     # Now the common Network info...
     if { $LinkInfoCommonNetworkOffset != 0 } {
       set NetOffset [chan tell $f]
       set NetLinkSize  [BinaryRead 4 $f]
       set NetLinkFlags [BinaryRead 4 $f]
       set NetNameOffset [BinaryRead 4 $f]
       set DevNameOffset [BinaryRead 4 $f]
       set NetProviderType [BinaryRead 4 $f]
       PutsHex NetLinkSize
       PutsHex NetOffset
       PutsHex NetLinkFlags 
       PutsHex NetNameOffset
       PutsHex DevNameOffset
       PutsHex NetProviderType
       if { $NetNameOffset > 0x14 } {
	      set NetNameOffsetUnc [BinaryRead 4 $f]
	      set DevNameOffsetUn [BinaryRead 4 $f]
       } else {
	      set NetNameOffsetUnc 0
	      set DevNameOffsetUn 0
       }
       PutsHex NetNameOffsetUnc
       PutsHex DevNameOffsetUn
     
       set NetName [GetNullTermString $f \
			[expr { $NetOffset + $NetNameOffset}]]
       PutsString NetName
       set DevName  [GetNullTermString $f \
			 [expr { $NetOffset + $DevNameOffset}]]
       if {$DevName == "\"" } {set DevName {}}
       PutsString DevName
       if { $NetNameOffsetUnc != 0 } {
         set NetNameUnc [GetNullTermStringUnc $f \
			  [expr { $NetOffset + $NetNameOffset}]]
         PutsString NetNameUnc
         set DevNameUnc  [GetNullTermStringUnc $f \
		 	  [expr { $NetOffset + $DevNameOffset}]]
       PutsString DevNameUnc
       }
     }
     # Common Path Suffix
     if { $LinkInfoCommonPathSuffixOffset != 0 } {
       set CommonPathSuffix \
	   [GetNullTermString $f \
		[expr {$LinkInfoOffset + $LinkInfoCommonPathSuffixOffset }]]
       PutsString CommonPathSuffix
     }
     #LinkInfoLocalBasePathOffsetUcd LinkInfoCommonPathSuffixOffsetUcd
     if { $LinkInfoLocalBasePathOffsetUcd != 0 } {
       set LocalBasePathUcd \
	   [GetNullTermStringUcd $f \
		[expr {$LinkInfoOffset + $LinkInfoLocalBasePathOffsetUcd }]]
       PutsString LocalBasePathUcd
     }
     if { $LinkInfoCommonPathSuffixOffsetUcd != 0 } {
       set CommonPathSuffixUcd \
	   [GetNullTermStringUcd $f \
		[expr {$LinkInfoOffset + $LinkInfoCommonPathSuffixOffsetUcd }]]
       PutsString CommonPathSuffixUcd
     }
   }
   # Here we look for string data.  Strings start with a count and
   # contain exactly that many characters...
   # the order is {name_string} {relative_path} {working_dir} 
   #              {command_line_arguments} {Icon_location}
   # all this is conditioned by the linkflags word...
   set val " Value"
   #  puts "doing strings $linkflags"
   foreach str {Name RelativePath WorkingDir Arguments IconLocation} {
     PutsSimple "[set $str] $str $linkflags [expr {$linkflags & [set $str]}]"
     if { $linkflags & [set $str]} {
       set len [BinaryRead 2 $f]
       if { $linkflags & $IsUniCode } {
	 chan configure $f -encoding unicode
       }
       set $str$val [chan read $f $len]
       chan configure $f -encoding [encoding system]
       PutsString $str$val
     }
   }
   # At this point the file position is at the beginning of the "extra data"
   # section of the file. Each of these starts with the length (4-bytes) followed
   # by a 4-byte blockSignature. We are only interested in the Env block and then
   # only if the "preferEnvPath" is set. For debug or other inspection we
   # will dump all that are present if the debug flag is set.
   # The "extra data" block is terminated by a block of size 4, i.e. it is
   # only long enough to contain its own length.
   #
   # The blockSignatures:
   set Env_             0xa0000001
   set Console_         0xA0000002
   set Tracker_         0xA0000003
   set Console_fe_      0xA0000004
   set Special_folder_  0xA0000005
   set Darwin_          0xA0000006
   set Icon_env_        0xA0000007
   set Shim_            0xA0000008
   set Property_store_  0xA0000009
   set Known_folder_    0xA000000B
   set Vista_and_above_ 0xA000000C
   set blockSigs {
     Env_
     Console_
     Tracker_
     Console_fe_
     Special_folder_
     Darwin_
     Icon_env_
     Shim_
     Property_store_
     Mystery_extra_
     Known_folder_
     Vista_and_above_ 
   }
   set curExtra [chan tell $f]
   while {[set size [BinaryRead 4 $f]] > 4 && [incr stoploop] < 14} {
     set sig [BinaryRead 4 $f]
     set indx [expr {($sig & 15) -1}]
     set asciiSig [lindex $blockSigs $indx]
     PutsSimple "\"Extra Data\" type $asciiSig found."
     # The exclusive forces the compare to use math and not string ops.
     if {$asciiSig == "Env_"} {
       # We can always get the ascii path
       set loc [chan tell $f]
       set EnvPath [GetNullTermString $f $loc]
       # This may or may not be there...
       set EnvPath2 [GetNullTermStringUnc $f [expr {$loc + 260}]]
       PutsString EnvPath
       PutsString EnvPath2
       if {$EnvPath2 != {}} {
	 set EnvPath $EnvPath2
       }
     } elseif {$asciiSig == "Property_store_"} {
       # We are not (or so I think) interested in the integers, but want
       # to grab the strings. Yes, this may be the result of the *.lnk
       # First lets burn the size
       set n 0
       set here [chan tell $f]
       while {[set ln  [BinaryRead 4 $f]] != 0} {
	 if {[set vers [BinaryRead 4 $f]] != 0x53505331} {
	   # We are lost! :(
	   set location [expr {$here + 4}]
	   set location2 [chan tell $f]
	   
       # 	   PutsSimple "Property Store version ([format 0x%08x $vers]) is wrong"
       # 	   PutsHex location
       # 	   PutsHex location2
       # 	   break
       # 	 }
       # 	 # get the format 4 full words of 4 bytes
       # 	 # GUID {D5CDD505-2E9C-101B-9397-08002B2CF9AE}
       # 	 set ns 0
       # 	 foreach val {0xD5CDD505 0x2E9C101B 0x93970800 0x2B2CF9AE} {
       # 	   set fnd [BinaryRead 4 $f]
       # 	   PutsHex fnd
       # 	   if {$fnd != $val} {
       # 	     PutsHex val
       # 	     incr ns
       # 	   }
       # 	 }
       # 	 if {$ns} {
       # 	   PutsSimple "Format is not a String, pushing on."
       # 	 } else {
       # 	   # We have strings...
       # 	   set here2 [chan tell $f]
       # 	   while {[set vln [BinaryRead 4 $f]] != 0 && [incr fs2] < 10} {
       # 	     set size [BinaryRead 4 $f]
       # 	     # burn the name size
       # 	     if {[BinaryRead 1 $f] != 0} {
       # 	       # lost again :(
       # 	       PutsSimple "Reserved word is $rw, not 0"
       # 	       break
       # 	     }
       # 	     set Property$n [GetNullTermStringUnc $f]
       # 	     PutsString Property$n
       # 	     incr n
       # 	     set here2 [expr {$here2 + $vln}]
       # 	     chan seek $f $here start
       # 	   }
       # 	 }
       # 	 set here [expr {$here + $ln}]
       # 	 chan seek $f $here  start
       # }
     }
     chan seek $f [expr {$curExtra + $size}]
   }

   # So lets build a target name
   # Prefered is basePath/CommonPathSuffix
   # DevName/CommonPathSuffix
   # relativePath
   # netName/commonPathSuffix
   # if we have neither relativePath nor CommonPathSuffix we fail
   set slash /
   set result "Confused"
   if {$linkflags & $PreferEnvPath} {
     set result $EnvPath
   } elseif {[info exists TargetId]} {
     set result $TargetId
   } elseif {![info exists CommonPathSuffix]} {
     if {![info exist RelativePath$val]} {
     } else {
       set result [set RelativePath$val]
     }
   } else {
     if { [info exists BasePath]} {
       set result $BasePath$CommonPathSuffix
     } elseif {[info exists DevName]} {
       set result $DevName/$CommonPathSuffix
     } elseif {[info exists NetName]} {
       set result $NetName/$CommonPathSuffix
     }				      
   }
   # Clean it up...
   #puts ">$result<"
   regsub -all {\\} $result {/} out
   regsub {/\./} $out {/} out
   # this only works for MSW
   if {$::MSW} {
     set out [replaceMsEnv $out]
   }
   # documentation of *.lnk files say we can not always trust...
   if {! $IsDir && [file exists $out] && [file isdirectory $out]} {
     set IsDir 1
   }
   #puts ">$IsDir< >$out<"
   setTo $dir $IsDir
   PutsString out
   PutsHex IsDir
   setTo $to $out
   close $f
   return 1 
}

# These are debug routines enable by diag in the LnkFile call
proc PutsHex { this } {
  upvar $this here
  if {[uplevel set diag]} {
    puts "$this = [format 0x%08x $here]"
  }
}
proc PutsString { this } {
  upvar $this here
  if {[uplevel set diag]} {
    puts "$this is $here"
  }
}

proc PutsSimple {this} {
  if {[uplevel set diag]} {
    puts "$this"
  }
}

#
# Here we try to verify a lnk pointer for linux
#
# we assume that the C:/ or other such ?:/ refer to the 
# mount point of (some) volume on the linux system.
# First we try the current volume. If sucessful it is entered in 
# a table for the next time.
# If that fails, we try a little table we keep to translate these.
# If that finds a file, we enter the new translation in our
# table.  If not, we fail with a null name.
#
# The other entry we decode is <??Folder> where ?? appears to be
# the current folder name.  We translate this to "."
#
# To do our work we require the mountpoint of the place the link
# was found and the found link.  We assume the link will be used
# within the current "pwd" (to make the "." work).

#
proc TranslateLnk {link curMountPt} {
  global glob
  set filePrefix {}
  switch -glob $link {
    {?:/*} {
      set first [string toupper [string range $link 0 0]]
      set filePrefix $curMountPt
      set file $filePrefix/[string range $link 3 end]
    }
    {//*} {set file $link}
    {*.url}   {return $link}
    {./*}     {set file $link }
    default   {set file "./$link" }
  }
  # Check if we found the file...
  if {![file exists $file]} {
    # if this is a ?:/ file and we have a previous working volume, try that
    if {$filePrefix != {} && [info exists glob(volume,$first)]} {
      foreach vol $glob(volume,$first) {     
	if {[file exists [set file $vol/[string range $link 3 end]]]} {
	  return $file
	}
      }
    }
    return {}
  } elseif {$filePrefix != {}} {
    # Allow several prefix to volume translations but only
    # one copy of a given transation.
    if {![info exists glob(volume,$first)] || \
	    $filePrefix ni $glob(volume,$first)} {
      lappend glob(volume,$first) $filePrefix
    }
  }
  return $file
}
	
