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

Merge with Daniel Herring's Windows link patches

parents d9902d26 1d334a23
Loading
Loading
Loading
Loading
+92 −5
Original line number Diff line number Diff line
@@ -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