X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tools-for-build%2Fwxs.lisp;h=bfe05b40d8ea75327a07dcd88f377e9ee3176c32;hb=8f79e6459a0e8fdd33c81a66f7e4adfa13f25005;hp=b6d4faa052885521044a97cd9bae6f681ff1cb3d;hpb=1acfa21e0796f5d72d776b0fd53645813d5f2d98;p=sbcl.git diff --git a/tools-for-build/wxs.lisp b/tools-for-build/wxs.lisp index b6d4faa..bfe05b4 100644 --- a/tools-for-build/wxs.lisp +++ b/tools-for-build/wxs.lisp @@ -13,6 +13,11 @@ (defvar *indent-level* 0) +(defvar *sbcl-source-root* + (truename + (merge-pathnames (make-pathname :directory (list :relative :up)) + (make-pathname :name nil :type nil :defaults *load-truename*)))) + (defun print-xml (sexp &optional (stream *standard-output*)) (destructuring-bind (tag &optional attributes &body children) sexp (when attributes (assert (evenp (length attributes)))) @@ -33,7 +38,22 @@ (print-xml sexp xml))) (defun application-name () - (format nil "SBCL ~A" (lisp-implementation-version))) + (format nil "Steel Bank Common Lisp ~A (~A)" (lisp-implementation-version) (machine-type))) + +(defun version-digits (&optional (horrible-thing (lisp-implementation-version))) + "Turns something like 0.pre7.14.flaky4.13 (see version.lisp-expr) + into an acceptable form for WIX (up to four dot-separated numbers)." + (with-output-to-string (output) + (loop repeat 4 + with position = 0 + for separator = "" then "." + for next-digit = (position-if #'digit-char-p horrible-thing + :start position) + while next-digit + do (multiple-value-bind (number end) + (parse-integer horrible-thing :start next-digit :junk-allowed t) + (format output "~A~D" separator number) + (setf position end))))) ;;;; GUID generation ;;;; @@ -47,7 +67,7 @@ (define-alien-type uuid (struct uuid - (data1 unsigned-long) + (data1 unsigned-int) (data2 unsigned-short) (data3 unsigned-short) (data4 (array unsigned-char 8)))) @@ -75,61 +95,42 @@ (free-alien guid)))) (defun list-all-contribs () - (loop for flag in (directory "../contrib/*/test-passed") + (loop for flag in (directory "../obj/asdf-cache/*/test-passed.test-report") collect (car (last (pathname-directory flag))))) +(defvar *id-char-substitutions* '((#\\ . #\_) + (#\/ . #\_) + (#\: . #\.) + (#\- . #\.))) + (defun id (string) ;; Mangle a string till it can be used as an Id. A-Z, a-z, 0-9, and ;; _ are ok, nothing else is. - (nsubstitute #\_ #\- - (nsubstitute #\. #\: - (nsubstitute #\. #\/ - (substitute #\. #\\ string))))) + (map 'string (lambda (c) + (or (cdr (assoc c *id-char-substitutions*)) + c)) + string)) (defun directory-id (name) - (id (format nil "Directory_~A" (enough-namestring name)))) - -(defun directory-names (pathname) - (let ((name (car (last (pathname-directory pathname))))) - (if (< 8 (length name)) - (list "Name" (subseq name 0 8) - "LongName" name) - (list "Name" name)))) + (id (format nil "Directory_~A" (enough-namestring name *sbcl-source-root*)))) (defun file-id (pathname) - (id (format nil "File_~A" (enough-namestring pathname)))) + (id (format nil "File_~A" (enough-namestring pathname *sbcl-source-root*)))) -(defparameter *ignored-directories* '("CVS" ".svn")) +(defparameter *ignored-directories* '("CVS" ".svn" "test-output")) (defparameter *pathname-type-abbrevs* '(("lisp" . "lsp") ("fasl" . "fas") ("SBCL" . "txt") ; README.SBCL -> README.txt ("texinfo" . "tfo") - ("lisp-temp" . "lmp"))) - -(defun file-names (pathname) - (if (or (< 8 (length (pathname-name pathname))) - (< 3 (length (pathname-type pathname)))) - (let ((short-name (let ((name (pathname-name pathname))) - (if (< 8 (length name)) - (subseq name 0 8) - name))) - (short-type (let ((type (pathname-type pathname))) - (if (< 3 (length type)) - (or (cdr (assoc type *pathname-type-abbrevs* :test #'equalp)) - (error "No abbreviation for type: ~A" type)) - type)))) - (list "Name" (if short-type - (format nil "~A.~A" short-name short-type) - short-name) - "LongName" (file-namestring pathname))) - (list "Name" (file-namestring pathname)))) + ("lisp-temp" . "lmp") + ("html" . "htm"))) (defparameter *components* nil) (defun component-id (pathname) - (let ((id (id (format nil "Contrib_~A" (enough-namestring pathname))))) + (let ((id (id (format nil "Contrib_~A" (enough-namestring pathname *sbcl-source-root*))))) (push id *components*) id)) @@ -141,32 +142,35 @@ (setf *components* nil))) (defun collect-1-component (root) - `("Directory" ("Id" ,(directory-id root) - ,@(directory-names root)) + `("Directory" ("Name" ,(car (last (pathname-directory root))) + "Id" ,(directory-id root)) ("Component" ("Id" ,(component-id root) "Guid" ,(make-guid) "DiskId" 1) ,@(loop for file in (directory (make-pathname :name :wild :type :wild :defaults root)) when (or (pathname-name file) (pathname-type file)) - collect `("File" ("Id" ,(file-id file) - ,@(file-names file) + collect `("File" ("Name" ,(file-namestring file) + "Id" ,(file-id file) "Source" ,(enough-namestring file))))))) +(defun directory-empty-p (dir) + (null (directory (make-pathname :name :wild :type :wild :defaults dir)))) + (defun collect-components (root) - (cons (collect-1-component root) - (loop for directory in - (directory - (merge-pathnames (make-pathname - :directory '(:relative :wild) - :name nil :type nil) - root)) - unless (member (car (last (pathname-directory directory))) - *ignored-directories* :test #'equal) - append (collect-components directory)))) + (append (unless (directory-empty-p root) (list (collect-1-component root))) + (loop for directory in + (directory + (merge-pathnames (make-pathname + :directory '(:relative :wild) + :name nil :type nil) + root)) + unless (member (car (last (pathname-directory directory))) + *ignored-directories* :test #'equal) + append (collect-components directory)))) (defun collect-contrib-components () - (loop for contrib in (directory "../contrib/*/test-passed") + (loop for contrib in (directory "../obj/asdf-cache/*/test-passed.test-report") append (collect-components (make-pathname :name nil :type nil :version nil @@ -184,63 +188,104 @@ ;; better at the time (xml-1.0 pathname - `("Wix" ("xmlns" "http://schemas.microsoft.com/wix/2003/01/wi") - ("Product" ("Id" "????????-????-????-????-????????????" + `("Wix" ("xmlns" "http://schemas.microsoft.com/wix/2006/wi") + ("Product" ("Id" "*" "Name" ,(application-name) - "Version" ,(lisp-implementation-version) + "Version" ,(version-digits) "Manufacturer" "http://www.sbcl.org" + "UpgradeCode" "BFF1D4CA-0153-4AAC-BB21-06DC4B8EAD7D" "Language" 1033) - ("Package" ("Id" "????????-????-????-????-????????????" + ("Package" ("Id" "*" "Manufacturer" "http://www.sbcl.org" "InstallerVersion" 200 - "Compressed" "yes")) + "Compressed" "yes" + #+x86-64 "Platform" #+x86-64 "x64" + "InstallScope" "perMachine")) ("Media" ("Id" 1 "Cabinet" "sbcl.cab" "EmbedCab" "yes")) + ("Property" ("Id" "PREVIOUSVERSIONSINSTALLED" + "Secure" "yes")) + ("Upgrade" ("Id" "BFF1D4CA-0153-4AAC-BB21-06DC4B8EAD7D") + ("UpgradeVersion" ("Minimum" "1.0.0" + "Maximum" "99.0.0" + "Property" "PREVIOUSVERSIONSINSTALLED" + "IncludeMinimum" "yes" + "IncludeMaximum" "no"))) + ("InstallExecuteSequence" () + ("RemoveExistingProducts" ("After" "InstallInitialize"))) ("Directory" ("Id" "TARGETDIR" "Name" "SourceDir") - ("Directory" ("Id" "ProgramMenuFolder" - "Name" "PMFolder")) - ("Directory" ("Id" "ProgramFilesFolder" + ("Directory" ("Id" "ProgramMenuFolder") + ("Component" ("Id" "SBCL_Shortcut" + "Guid" ,(make-guid)) + ("Shortcut" ("Id" "sbcl.lnk" + "Name" ,(application-name) + "Target" "[INSTALLDIR]sbcl.exe" + "Arguments" "--core \"[#sbcl.core]\"")) + ("RegistryValue" ("Root" "HKCU" + "Key" ,(application-name) + "Name" "installed" + "Type" "integer" + "Value" "1" + "KeyPath" "yes")))) + ("Directory" ("Id" #-x86-64 "ProgramFilesFolder" #+x86-64 "ProgramFiles64Folder" "Name" "PFiles") ("Directory" ("Id" "BaseFolder" - "Name" "SBCL" - "LongName" "Steel Bank Common Lisp") + "Name" "Steel Bank Common Lisp") ("Directory" ("Id" "VersionFolder" "Name" ,(lisp-implementation-version)) ("Directory" ("Id" "INSTALLDIR") - ("Component" ("Id" "SBCL_Base" + ("Component" ("Id" "SBCL_SetHOME" "Guid" ,(make-guid) "DiskId" 1) ("Environment" ("Id" "Env_SBCL_HOME" + "System" "yes" "Action" "set" "Name" "SBCL_HOME" "Part" "all" - "Value" "[INSTALLDIR]")) + "Value" "[INSTALLDIR]"))) + + ("Component" ("Id" "SBCL_SetPATH" + "Guid" ,(make-guid) + "DiskId" 1) ("Environment" ("Id" "Env_PATH" + "System" "yes" "Action" "set" "Name" "PATH" - "Part" "first" - "Value" "[INSTALLDIR]")) - ,(make-extension "fasl" "application/x-lisp-fasl") - ,(make-extension "lisp" "text/x-lisp-source") - ("File" ("Id" "sbcl.exe" - "Name" "sbcl.exe" - "Source" "../src/runtime/sbcl.exe") - ("Shortcut" ("Id" "sbcl.lnk" - "Directory" "ProgramMenuFolder" - "Name" "SBCL" - "LongName" ,(application-name) - "Arguments" "--core \"[#sbcl.core]\""))) - ("File" ("Id" "sbcl.core" - "Name" "sbcl.cre" - "LongName" "sbcl.core" + "Part" "last" + "Value" "[INSTALLDIR]"))) + ("Component" ("Id" "SBCL_Base" + "Guid" ,(make-guid) + "DiskId" 1) + ;; If we want to associate files with SBCL, this + ;; is how it's done -- but doing this by default + ;; and without asking the user for permission Is + ;; Bad. Before this is enabled we need to figure out + ;; how to make WiX ask for permission for this... + ;; ,(make-extension "fasl" "application/x-lisp-fasl") + ;; ,(make-extension "lisp" "text/x-lisp-source") + ("File" ("Name" "sbcl.exe" + "Source" "../src/runtime/sbcl.exe")) + ("File" ("Name" "sbcl.core" "Source" "sbcl.core"))) ,@(collect-contrib-components)))))) ("Feature" ("Id" "Minimal" + "Title" "SBCL Executable" "ConfigurableDirectory" "INSTALLDIR" "Level" 1) ("ComponentRef" ("Id" "SBCL_Base")) - ,@(ref-all-components)) + ("Feature" ("Id" "Contrib" "Level" 1 "Title" "Contributed Modules") + ,@(ref-all-components)) + ("Feature" ("Id" "Shortcut" "Level" 1 "Title" "Add Start Menu Shortcut") + ("ComponentRef" ("Id" "SBCL_Shortcut"))) + ("Feature" ("Id" "SetPath" "Level" 1 "Title" "Set Environment Variable: PATH") + ("ComponentRef" ("Id" "SBCL_SetPATH"))) + ;; SetHome is still enabled by default (level 1), because SBCL + ;; does not yet support running without SBCL_HOME: + ("Feature" ("Id" "SetHome" "Level" 1 "Title" "Set Environment Variable: SBCL_HOME") + ("ComponentRef" ("Id" "SBCL_SetHOME")))) + ("WixVariable" ("Id" "WixUILicenseRtf" + "Value" "License.rtf")) ("Property" ("Id" "WIXUI_INSTALLDIR" "Value" "INSTALLDIR")) - ("UIRef" ("Id" "WixUI_InstallDir")))))) + ("UIRef" ("Id" "WixUI_FeatureTree"))))))