Loading asdf.lisp +92 −5 Original line number Diff line number Diff line Loading @@ -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) Loading Loading @@ -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 Loading Loading @@ -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 Loading Loading
asdf.lisp +92 −5 Original line number Diff line number Diff line Loading @@ -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) Loading Loading @@ -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 Loading Loading @@ -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 Loading