Skip to content
Snippets Groups Projects
Commit 96e332a5 authored by D Herring's avatar D Herring
Browse files

Windows shortcut support

Copied from David Lichteblau's patched ASDF
http://www.lichteblau.com/blubba/shortcut/asdf.lisp
parent 65621197
No related branches found
No related tags found
No related merge requests found
......@@ -355,13 +355,22 @@ and NIL NAME and TYPE components"
(let ((name (coerce-name system)))
(block nil
(dolist (dir *central-registry*)
(let* ((defaults (eval dir))
(file (and defaults
(make-pathname
(let ((defaults (eval dir)))
(when defaults
(let* ((file (make-pathname
:defaults defaults :version :newest
:name name :type "asd" :case :local))
#+win32
(lnk (make-pathname
:defaults defaults :version :newest
:name name :type "asd" :case :local))))
(if (and file (probe-file file))
(return file)))))))
:name name :type "asd.lnk" :case :local)))
(when (probe-file file)
(return file))
#+win32
(when (probe-file lnk)
(let ((target (parse-windows-shortcut lnk)))
(when target
(return (pathname target))))))))))))
(defun make-temporary-package ()
(flet ((try (counter)
......@@ -1172,6 +1181,84 @@ output to *VERBOSE-OUT*. Returns the shell's exit code."
(hyperdocumentation (symbol-package name) name doc-type))
;;;; Windows shortcut support. Based on:
;;; Jesse Hager: The Windows Shortcut File Format.
;;; http://www.wotsit.org/list.asp?fc=13
(defparameter *link-initial-dword* 76)
(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
(defun read-null-terminated-string (s)
(with-output-to-string (out)
(loop
for code = (read-byte s)
until (zerop code)
do (write-char (code-char code) out))))
(defun read-little-endian (s &optional (bytes 4))
(let ((result 0))
(loop
for i from 0 below bytes
do
(setf result (logior result (ash (read-byte s) (* 8 i)))))
result))
(defun parse-windows-shortcut (pathname)
(with-open-file (s pathname :element-type '(unsigned-byte 8))
(handler-case
(when (and (= (read-little-endian s) *link-initial-dword*)
(let ((header (make-array (length *link-guid*))))
(read-sequence header s)
(equalp header *link-guid*)))
(let ((flags (read-little-endian s)))
(file-position s 76) ;skip rest of header
(when (logbitp 0 flags)
;; skip shell item id list
(let ((length (read-little-endian s 2)))
(file-position s (+ length (file-position s)))))
(cond
((logbitp 1 flags)
(parse-file-location-info s))
(t
(when (logbitp 2 flags)
;; skip description string
(let ((length (read-little-endian s 2)))
(file-position s (+ length (file-position s)))))
(when (logbitp 3 flags)
;; finally, our pathname
(let* ((length (read-little-endian s 2))
(buffer (make-array length)))
(read-sequence buffer s)
(map 'string #'code-char buffer)))))))
(end-of-file ()
nil))))
(defun parse-file-location-info (s)
(let ((start (file-position s))
(total-length (read-little-endian s))
(end-of-header (read-little-endian s))
(fli-flags (read-little-endian s))
(local-volume-offset (read-little-endian s))
(local-offset (read-little-endian s))
(network-volume-offset (read-little-endian s))
(remaining-offset (read-little-endian s)))
(declare (ignore total-length end-of-header local-volume-offset))
(unless (zerop fli-flags)
(cond
((logbitp 0 fli-flags)
(file-position s (+ start local-offset)))
((logbitp 1 fli-flags)
(file-position s (+ start
network-volume-offset
#x14))))
(concatenate 'string
(read-null-terminated-string s)
(progn
(file-position s (+ start remaining-offset))
(read-null-terminated-string s))))))
(pushnew :asdf *features*)
#+sbcl
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment