diff --git a/asdf.lisp b/asdf.lisp index c82c6e8cf8e6dc64f7d69aed3b10ee57249d903e..f1f6d7c4aa277786763b7895175f2cc33ce0b519 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -488,12 +488,21 @@ actually-existing directory." (dolist (dir *central-registry*) (let ((defaults (eval dir))) (cond ((directory-pathname-p defaults) - (let ((file (and defaults - (make-pathname - :defaults defaults :version :newest - :name name :type "asd" :case :local)))) - (if (and file (probe-file file)) - (return file)))) + (when defaults + (let* ((file (make-pathname + :defaults defaults :version :newest + :name name :type "asd" :case :local)) + #+win32 + (shortcut (make-pathname + :defaults defaults :version :newest + :name name :type "asd.lnk" :case :local))) + (when (probe-file file) + (return file)) + #+win32 + (when (probe-file shortcut) + (let ((target (parse-windows-shortcut shortcut))) + (when target + (return (pathname target)))))))) (t (restart-case (let* ((*print-circle* nil) @@ -1540,6 +1549,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