Skip to content
Snippets Groups Projects
Commit 4e53ae5e authored by Gary King's avatar Gary King
Browse files

Merge with Daniel Herring's Windows link patches

parents d9902d26 1d334a23
Branches
Tags 1.361
No related merge requests found
......@@ -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)
for key = (and data (first data))
for value = (and data (second data))
while data
for key = (first data)
for value = (second 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
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment