From 2f1783fe3644c34eec7a317d6326c00e1d77e312 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <fare@tunes.org> Date: Thu, 20 Oct 2011 16:54:52 -0400 Subject: [PATCH] 2.017.22: Make the unix vs windows discrimination a runtime issue. Indeed, at least on ABCL, the same binaries can run on either. On other implementations, the same may or may not hold for FASLs. --- asdf.asd | 2 +- asdf.lisp | 299 ++++++++++++++++++++++++++----------------------- debian/control | 2 +- 3 files changed, 159 insertions(+), 144 deletions(-) diff --git a/asdf.asd b/asdf.asd index 52354c4f..0666e9d7 100644 --- a/asdf.asd +++ b/asdf.asd @@ -14,7 +14,7 @@ :licence "MIT" :description "Another System Definition Facility" :long-description "ASDF builds Common Lisp software organized into defined systems." - :version "2.017.21" ;; to be automatically updated by bin/bump-revision + :version "2.017.22" ;; to be automatically updated by bin/bump-revision :depends-on () :components ((:file "asdf") diff --git a/asdf.lisp b/asdf.lisp index 3dd75960..6a24cc0b 100755 --- a/asdf.lisp +++ b/asdf.lisp @@ -1,5 +1,5 @@ ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.017.21: Another System Definition Facility. +;;; This is ASDF 2.017.22: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel@common-lisp.net>. @@ -67,11 +67,6 @@ (and (= system::*gcl-major-version* 2) (< system::*gcl-minor-version* 7))) (pushnew :gcl-pre2.7 *features*)) - (cond - ((intersection *features* '(:asdf-unix :unix :cygwin :darwin)) - (pushnew :asdf-unix *features*)) - ((intersection *features* '(:asdf-windows :win32 :windows :mswindows :mingw32)) - (pushnew :asdf-windows *features*))) ;;; make package if it doesn't exist yet. ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it. (unless (find-package :asdf) @@ -115,7 +110,7 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.017.21") + (asdf-version "2.017.22") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -1416,6 +1411,81 @@ NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3" (and x y (= (car x) (car y)) (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) +;;;; ----------------------------------------------------------------- +;;;; Windows shortcut support. Based on: +;;;; +;;;; Jesse Hager: The Windows Shortcut File Format. +;;;; http://www.wotsit.org/list.asp?fc=13 + +#-clisp +(progn +(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)) + (loop :for i :from 0 :below bytes + :sum (ash (read-byte s) (* 8 i)))) + +(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)))))) + +(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))))) + ;;;; ------------------------------------------------------------------------- ;;;; Finding systems @@ -1496,6 +1566,26 @@ This is for backward compatibilily. Going forward, we recommend new users should be using the source-registry. ") +(defun* featurep (x &optional (features *features*)) + (cond + ((atom x) + (and (member x features) t)) + ((eq 'not (car x)) + (assert (null (cddr x))) + (not (featurep (cadr x) features))) + ((eq 'or (car x)) + (some #'(lambda (x) (featurep x features)) (cdr x))) + ((eq 'and (car x)) + (every #'(lambda (x) (featurep x features)) (cdr x))) + (t + (error "Malformed feature specification ~S" x)))) + +(defun* os-unix-p () + (featurep '(or :unix :cygwin :darwin))) + +(defun* os-windows-p () + (and (not (os-unix-p)) (featurep '(or :win32 :windows :mswindows :mingw32)))) + (defun* probe-asd (name defaults) (block nil (when (directory-pathname-p defaults) @@ -1504,16 +1594,17 @@ Going forward, we recommend new users should be using the source-registry. :version :newest :case :local :type "asd"))) (when (probe-file* file) (return file))) - #+(and asdf-windows (not clisp)) - (let ((shortcut - (make-pathname - :defaults defaults :version :newest :case :local - :name (concatenate 'string name ".asd") - :type "lnk"))) - (when (probe-file* shortcut) - (let ((target (parse-windows-shortcut shortcut))) - (when target - (return (pathname target))))))))) + #-clisp + (when (os-windows-p) + (let ((shortcut + (make-pathname + :defaults defaults :version :newest :case :local + :name (concatenate 'string name ".asd") + :type "lnk"))) + (when (probe-file* shortcut) + (let ((target (parse-windows-shortcut shortcut))) + (when target + (return (pathname target)))))))))) (defun* sysdef-central-registry-search (system) (let ((name (coerce-name system)) @@ -2859,10 +2950,11 @@ output to *VERBOSE-OUT*. Returns the shell's exit code." (nth-value 1 (ccl:external-process-status (ccl:run-program - #+asdf-unix "/bin/sh" - #+asdf-unix (list "-c" command) - #+asdf-windows (format nil "CMD /C ~A" command) - #+asdf-windows () ; BEWARE! + (cond + ((os-unix-p) "/bin/sh") + ((os-windows-p) (format nil "CMD /C ~A" command)) ; BEWARE! + (t (error "Unsupported OS"))) + (if (os-unix-p) (list "-c" command) '()) :input nil :output *verbose-out* :wait t))) #+(or cmu scl) @@ -2879,12 +2971,9 @@ output to *VERBOSE-OUT*. Returns the shell's exit code." (lisp:system command) #+lispworks - (system:call-system-showing-output - command - #+asdf-unix :shell-type #+asdf-unix "/bin/sh" - :show-cmd nil - :prefix "" - :output-stream *verbose-out*) + (apply 'system:call-system-showing-output command + :show-cmd nil :prefix "" :output-stream *verbose-out* + (when (os-unix-p) '(:shell-type "/bin/sh"))) #+mcl (ccl::with-cstrs ((%command command)) (_system %command)) @@ -3053,9 +3142,8 @@ located." ;;; --------------------------------------------------------------------------- ;;; Generic support for configuration files -(defparameter *inter-directory-separator* - #+asdf-unix #\: - #-asdf-unix #\;) +(defun inter-directory-separator () + (if (os-unix-p) #\: #\;)) (defun* user-homedir () (truenamize @@ -3076,27 +3164,28 @@ located." ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS") :for dir :in (split-string dirs :separator ":") :collect (try dir "common-lisp/")) - #+asdf-windows - ,@`(,(try (or #+lispworks (sys:get-folder-path :local-appdata) - (getenv "LOCALAPPDATA")) - "common-lisp/config/") - ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData - ,(try (or #+lispworks (sys:get-folder-path :appdata) - (getenv "APPDATA")) - "common-lisp/config/")) + ,@(when (os-windows-p) + `(,(try (or #+lispworks (sys:get-folder-path :local-appdata) + (getenv "LOCALAPPDATA")) + "common-lisp/config/") + ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData + ,(try (or #+lispworks (sys:get-folder-path :appdata) + (getenv "APPDATA")) + "common-lisp/config/"))) ,(try (user-homedir) ".config/common-lisp/"))))) (remove-duplicates (remove-if #'null dirs) :from-end t :test 'equal))) (defun* system-configuration-directories () - (remove-if - #'null - `(#+asdf-windows - ,(flet ((try (x sub) (try-directory-subpath x sub))) + (cond + ((os-unix-p) '(#p"/etc/common-lisp/")) + ((os-windows-p) + (aif + (flet ((try (x sub) (try-directory-subpath x sub))) ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData (try (or #+lispworks (sys:get-folder-path :common-appdata) (getenv "ALLUSERSAPPDATA") (try (getenv "ALLUSERSPROFILE") "Application Data/")) "common-lisp/config/")) - #+asdf-unix #p"/etc/common-lisp/"))) + (list it))))) (defun* in-first-directory (dirs x) (loop :for dir :in dirs @@ -3215,12 +3304,12 @@ and the order is by decreasing length of namestring of the source pathname.") (flet ((try (x &rest sub) (and x `(,x ,@sub)))) (or (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation) - #+asdf-windows - (try (or #+lispworks (sys:get-folder-path :local-appdata) - (getenv "LOCALAPPDATA") - #+lispworks (sys:get-folder-path :appdata) - (getenv "APPDATA")) - "common-lisp" "cache" :implementation) + (when (os-windows-p) + (try (or #+lispworks (sys:get-folder-path :local-appdata) + (getenv "LOCALAPPDATA") + #+lispworks (sys:get-folder-path :appdata) + (getenv "APPDATA")) + "common-lisp" "cache" :implementation)) '(:home ".cache" "common-lisp" :implementation)))) (defun* output-translations () @@ -3347,8 +3436,7 @@ Please remove it from your ASDF configuration")) (relative-component-p (c) (typep c '(or string pathname (member :default-directory :*/ :**/ :*.*.* - :implementation :implementation-type - #+asdf-unix :uid))))) + :implementation :implementation-type))))) (or (typep x 'boolean) (absolute-component-p x) (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x)))))) @@ -3408,7 +3496,8 @@ Please remove it from your ASDF configuration")) :with start = 0 :with end = (length string) :with source = nil - :for i = (or (position *inter-directory-separator* string :start start) end) :do + :with separator = (inter-directory-separator) + :for i = (or (position separator string :start start) end) :do (let ((s (subseq string start i))) (cond (source @@ -3721,81 +3810,6 @@ call that function where you would otherwise have loaded and configured A-B-L.") (t t) :ignore-inherited-configuration)))) -;;;; ----------------------------------------------------------------- -;;;; Windows shortcut support. Based on: -;;;; -;;;; Jesse Hager: The Windows Shortcut File Format. -;;;; http://www.wotsit.org/list.asp?fc=13 - -#+(and asdf-windows (not clisp)) -(progn -(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)) - (loop :for i :from 0 :below bytes - :sum (ash (read-byte s) (* 8 i)))) - -(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)))))) - -(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))))) - ;;;; ----------------------------------------------------------------- ;;;; Source Registry Configuration, by Francois-Rene Rideau ;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918 @@ -3956,7 +3970,8 @@ with a different configuration, so the configuration would be re-read then." :with directives = () :with start = 0 :with end = (length string) - :for pos = (position *inter-directory-separator* string :start start) :do + :with separator = (inter-directory-separator) + :for pos = (position separator string :start start) :do (let ((s (subseq string start (or pos end)))) (flet ((check (dir) (unless (absolute-pathname-p dir) @@ -4009,20 +4024,20 @@ with a different configuration, so the configuration would be re-read then." #+sbcl (:directory ,(try (user-homedir) ".sbcl/systems/")) (:directory ,(default-directory)) ,@(loop :for dir :in - `(#+asdf-unix - ,@`(,(or (getenv "XDG_DATA_HOME") - (try (user-homedir) ".local/share/")) - ,@(split-string (or (getenv "XDG_DATA_DIRS") - "/usr/local/share:/usr/share") - :separator ":")) - #+asdf-windows - ,@`(,(or #+lispworks (sys:get-folder-path :local-appdata) - (getenv "LOCALAPPDATA")) - ,(or #+lispworks (sys:get-folder-path :appdata) - (getenv "APPDATA")) - ,(or #+lispworks (sys:get-folder-path :common-appdata) - (getenv "ALLUSERSAPPDATA") - (try (getenv "ALLUSERSPROFILE") "Application Data/")))) + `(,@(when (os-unix-p) + `(,(or (getenv "XDG_DATA_HOME") + (try (user-homedir) ".local/share/")) + ,@(split-string (or (getenv "XDG_DATA_DIRS") + "/usr/local/share:/usr/share") + :separator ":"))) + ,@(when (os-windows-p) + `(,(or #+lispworks (sys:get-folder-path :local-appdata) + (getenv "LOCALAPPDATA")) + ,(or #+lispworks (sys:get-folder-path :appdata) + (getenv "APPDATA")) + ,(or #+lispworks (sys:get-folder-path :common-appdata) + (getenv "ALLUSERSAPPDATA") + (try (getenv "ALLUSERSPROFILE") "Application Data/"))))) :collect `(:directory ,(try dir "common-lisp/systems/")) :collect `(:tree ,(try dir "common-lisp/source/"))) :inherit-configuration))) diff --git a/debian/control b/debian/control index 853ee2c0..69ba040f 100644 --- a/debian/control +++ b/debian/control @@ -7,7 +7,7 @@ Uploaders: Peter Van Eynde <pvaneynd@debian.org>, Francois-Rene Rideau <fare@tunes.org> Build-Depends: debhelper (>> 7) Build-Depends-Indep: texinfo, texlive-extra-utils, texlive, texlive-generic-recommended -Standards-Version: 3.9.1.0 +Standards-Version: 3.9.2 Homepage: http://common-lisp.net/project/asdf/ Vcs-Git: git://common-lisp.net/projects/asdf/asdf.git -- GitLab