Commit 1d334a23 authored by D Herring's avatar D Herring
Browse files

simple merge

parents 061bb242 8308b237
......@@ -587,12 +587,21 @@ actually-existing directory."
(dolist (dir *central-registry*)
(let ((defaults (eval dir)))
(cond ((directory-pathname-p defaults)
(let ((file (and defaults
: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))
#+(or win32 windows)
(shortcut (make-pathname
:defaults defaults :version :newest
:name name :type "asd.lnk" :case :local)))
(when (probe-file file)
(return file))
#+(or win32 windows)
(when (probe-file shortcut)
(let ((target (parse-windows-shortcut shortcut)))
(when target
(return (pathname target))))))))
(let* ((*print-circle* nil)
......@@ -1374,9 +1383,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
......@@ -1552,6 +1561,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.
(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)
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))
for i from 0 below bytes
(setf result (logior result (ash (read-byte s) (* 8 i)))))
(defun parse-windows-shortcut (pathname)
(with-open-file (s pathname :element-type '(unsigned-byte 8))
(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)))))
((logbitp 1 flags)
(parse-file-location-info s))
(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 ()
(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)
((logbitp 0 fli-flags)
(file-position s (+ start local-offset)))
((logbitp 1 fli-flags)
(file-position s (+ start
(concatenate 'string
(read-null-terminated-string s)
(file-position s (+ start remaining-offset))
(read-null-terminated-string s))))))
(pushnew :asdf *features*)
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