Commit 4e53ae5e authored by Gary King's avatar Gary King
Browse files

Merge with Daniel Herring's Windows link patches

parents d9902d26 1d334a23
......@@ -597,9 +597,18 @@ actually-existing directory."
(let ((file (and defaults
(make-pathname
:defaults defaults :version :newest
:name name :type "asd" :case :local))))
:name name :type "asd" :case :local)))
#+(or win32 windows)
(shortcut (make-pathname
:defaults defaults :version :newest
:name name :type "asd.lnk" :case :local)))
(if (and file (probe-file file))
(return file))))
(return file))
#+(or win32 windows)
(when (probe-file shortcut)
(let ((target (parse-windows-shortcut shortcut)))
(when target
(return (pathname target)))))))
(t
(restart-case
(let* ((*print-circle* nil)
......@@ -1396,9 +1405,9 @@ Returns the new tree (which probably shares structure with the old one)"
(loop for name in +asdf-methods+ do
(let ((keyword (intern (symbol-name name) :keyword)))
(loop for data = rest then (cddr data)
while data
for key = (first data)
for value = (second data)
for key = (and data (first data))
for value = (and data (second data))
while data
when (eq key keyword) do
(destructuring-bind (op qual (o c) &body body) value
(pushnew
......@@ -1569,6 +1578,84 @@ output to `*verbose-out*`. Returns the shell's exit code."
:directory directory)
(system-source-directory system))))
;;;; 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
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment