tools-for-build/wxs.lisp

   1 ;;;; Generate WiX XML Source, from which we eventually generate the .MSI
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 ;;;; XML generation
  13
  14 (defvar *indent-level* 0)
  15
  16 (defvar *sbcl-source-root*
  17   (truename
  18    (merge-pathnames (make-pathname :directory (list :relative :up))
  19                     (make-pathname :name nil :type nil :defaults *load-truename*))))
  20
  21 (defun print-xml (sexp &optional (stream *standard-output*))
  22   (destructuring-bind (tag &optional attributes &body children) sexp
  23     (when attributes (assert (evenp (length attributes))))
  24     (format stream "~V@T<~A~{ ~A='~A'~}~@[/~]>~%"
  25             *indent-level* tag attributes (not children))
  26     (let ((*indent-level* (+ *indent-level* 3)))
  27       (dolist (child children)
  28         (unless (listp child)
  29           (error "Malformed child: ~S in ~S" child children))
  30         (print-xml child stream)))
  31     (when children
  32       (format stream "~V@T</~A>~%" *indent-level* tag))))
  33
  34 (defun xml-1.0 (pathname sexp)
  35   (with-open-file (xml pathname :direction :output :if-exists :supersede
  36                        :external-format :ascii)
  37      (format xml "<?xml version='1.0'?>~%")
  38      (print-xml sexp xml)))
  39
  40 (defun application-name ()
  41   "Steel Bank Common Lisp")
  42
  43 (defun application-name/version+machine-type ()
  44   (format nil "~A ~A (~A)"
  45           (application-name) (lisp-implementation-version) (machine-type)))
  46
  47 (defun manufacturer-name ()
  48   "http://www.sbcl.org")
  49
  50 (defun upgrade-code ()
  51   "BFF1D4CA-0153-4AAC-BB21-06DC4B8EAD7D")
  52
  53 (defun version-digits (&optional (horrible-thing (lisp-implementation-version)))
  54   "Turns something like 0.pre7.14.flaky4.13 (see version.lisp-expr)
  55   into an acceptable form for WIX (up to four dot-separated numbers)."
  56   (with-output-to-string (output)
  57     (loop repeat 4
  58           with position = 0
  59           for separator = "" then "."
  60           for next-digit = (position-if #'digit-char-p horrible-thing
  61                                     :start position)
  62           while next-digit
  63           do (multiple-value-bind (number end)
  64                  (parse-integer horrible-thing :start next-digit :junk-allowed t)
  65                (format output "~A~D" separator number)
  66                (setf position end)))))
  67
  68 ;;;; GUID generation
  69 ;;;;
  70 ;;;; Apparently this willy-nilly regeneration of GUIDs is a bad thing, and
  71 ;;;; we should probably have a single GUID per release / Component, so
  72 ;;;; that no matter by whom the .MSI is built the GUIDs are the same.
  73 ;;;;
  74 ;;;; Something to twiddle on a rainy day, I think.
  75
  76 (load-shared-object "OLE32.DLL")
  77
  78 (define-alien-type uuid
  79     (struct uuid
  80             (data1 unsigned-int)
  81             (data2 unsigned-short)
  82             (data3 unsigned-short)
  83             (data4 (array unsigned-char 8))))
  84
  85 (define-alien-routine ("CoCreateGuid" co-create-guid) int (guid (* uuid)))
  86
  87 (defun uuid-string (uuid)
  88   (declare (type (alien (* uuid)) uuid))
  89   (let ((data4 (slot uuid 'data4)))
  90     (format nil "~8,'0X-~4,'0X-~4,'0X-~2,'0X~2,'0X-~{~2,'0X~}"
  91             (slot uuid 'data1)
  92             (slot uuid 'data2)
  93             (slot uuid 'data3)
  94             (deref data4 0)
  95             (deref data4 1)
  96             (loop for i from 2 upto 7 collect (deref data4 i)))))
  97
  98 (defun make-guid ()
  99   (let (guid)
 100     (unwind-protect
 101          (progn
 102            (setf guid (make-alien (struct uuid)))
 103            (co-create-guid guid)
 104            (uuid-string guid))
 105       (free-alien guid))))
 106
 107 (defvar *id-char-substitutions* '((#\\ . #\_)
 108                                   (#\/ . #\_)
 109                                   (#\: . #\.)
 110                                   (#\- . #\.)))
 111
 112 (defun id (string)
 113   ;; Mangle a string till it can be used as an Id. A-Z, a-z, 0-9, and
 114   ;; _ are ok, nothing else is.
 115   (map 'string (lambda (c)
 116                  (or (cdr (assoc c *id-char-substitutions*))
 117                      c))
 118        string))
 119
 120 (defun directory-id (name)
 121   (id (format nil "Directory_~A" (enough-namestring name *sbcl-source-root*))))
 122
 123 (defun file-id (pathname)
 124   (id (format nil "File_~A" (enough-namestring pathname *sbcl-source-root*))))
 125
 126 (defparameter *ignored-directories* '("CVS" ".svn" "test-output"))
 127
 128 (defparameter *pathname-type-abbrevs*
 129   '(("lisp" . "lsp")
 130     ("fasl" . "fas")
 131     ("SBCL" . "txt") ; README.SBCL -> README.txt
 132     ("texinfo" . "tfo")
 133     ("lisp-temp" . "lmp")
 134     ("html" . "htm")))
 135
 136 (defparameter *components* nil)
 137
 138 (defun component-id (pathname)
 139   (let ((id (id (format nil "Contrib_~A" (enough-namestring pathname *sbcl-source-root*)))))
 140     (push id *components*)
 141     id))
 142
 143 (defun ref-all-components ()
 144   (prog1
 145       (mapcar (lambda (id)
 146                 `("ComponentRef" ("Id" ,id)))
 147               *components*)
 148     (setf *components* nil)))
 149
 150 (defun collect-1-component (root)
 151   `("Directory" ("Name" ,(car (last (pathname-directory root)))
 152                  "Id" ,(directory-id root))
 153     ("Component" ("Id" ,(component-id root)
 154                   "Guid" ,(make-guid)
 155                   "DiskId" 1
 156                   #+x86-64 "Win64" #+x86-64 "yes")
 157      ,@(loop for file in (directory
 158                           (make-pathname :name :wild :type :wild :defaults root))
 159              when (or (pathname-name file) (pathname-type file))
 160              collect `("File" ("Name" ,(file-namestring file)
 161                                "Id" ,(file-id file)
 162                                "Source" ,(enough-namestring file)))))))
 163
 164 (defun directory-empty-p (dir)
 165   (null (directory (make-pathname :name :wild :type :wild :defaults dir))))
 166
 167 (defun collect-components (root)
 168   (append (unless (directory-empty-p root) (list (collect-1-component root)))
 169           (loop for directory in
 170                 (directory
 171                  (merge-pathnames (make-pathname
 172                                    :directory '(:relative :wild)
 173                                    :name nil :type nil)
 174                                   root))
 175                 unless (member (car (last (pathname-directory directory)))
 176                                *ignored-directories* :test #'equal)
 177                 append (collect-components directory))))
 178
 179 (defun collect-contrib-components ()
 180   (collect-components "../obj/sbcl-home/contrib/"))
 181
 182 (defun make-extension (type mime)
 183   `("Extension" ("Id" ,type "ContentType" ,mime)
 184     ("Verb" ("Id" ,(format nil "load_~A" type)
 185              "Argument" "--core \"[#sbcl.core]\" --load \"%1\""
 186              "Command" "Load with SBCL"
 187              "Target" "[#sbcl.exe]"))))
 188
 189 (defun write-wxs (pathname)
 190   ;; both :INVERT and :PRESERVE could be used here, but this seemed
 191   ;; better at the time
 192   (xml-1.0
 193    pathname
 194    `("Wix" ("xmlns" "http://schemas.microsoft.com/wix/2006/wi")
 195      ("Product" ("Id" "*"
 196                  "Name" ,(application-name/version+machine-type)
 197                  "Version" ,(version-digits)
 198                  "Manufacturer" ,(manufacturer-name)
 199                  "UpgradeCode" ,(upgrade-code)
 200                  "Language" 1033)
 201       ("Package" ("Id" "*"
 202                   "Manufacturer" ,(manufacturer-name)
 203                   "InstallerVersion" 200
 204                   "Compressed" "yes"
 205                   #+x86-64 "Platform" #+x86-64 "x64"
 206                   "InstallScope" "perMachine"))
 207       ("Media" ("Id" 1
 208                 "Cabinet" "sbcl.cab"
 209                 "EmbedCab" "yes"))
 210       ("Property" ("Id" "PREVIOUSVERSIONSINSTALLED"
 211                    "Secure" "yes"))
 212       ("Upgrade" ("Id" ,(upgrade-code))
 213        ("UpgradeVersion" ("Minimum" "1.0.0"
 214                           "Maximum" "99.0.0"
 215                           "Property" "PREVIOUSVERSIONSINSTALLED"
 216                           "IncludeMinimum" "yes"
 217                           "IncludeMaximum" "no")))
 218       ("InstallExecuteSequence" ()
 219        ("RemoveExistingProducts" ("After" "InstallInitialize")))
 220       ("Directory" ("Id" "TARGETDIR"
 221                     "Name" "SourceDir")
 222        ("Directory" ("Id" "ProgramMenuFolder")
 223         ("Directory" ("Id" "ProgramMenuDir"
 224                       "Name" ,(application-name/version+machine-type))
 225          ("Component" ("Id" "ProgramMenuDir"
 226                        "Guid" ,(make-guid))
 227           ("RemoveFolder" ("Id" "ProgramMenuDir"
 228                            "On" "uninstall"))
 229           ("RegistryValue" ("Root" "HKCU"
 230                             "Key" "Software\\[Manufacturer]\\[ProductName]"
 231                             "Type" "string"
 232                             "Value" ""
 233                             "KeyPath" "yes")))))
 234        ("Directory" ("Id" #-x86-64 "ProgramFilesFolder" #+x86-64 "ProgramFiles64Folder"
 235                      "Name" "PFiles")
 236         ("Directory" ("Id" "BaseFolder"
 237                       "Name" ,(application-name))
 238          ("Directory" ("Id" "VersionFolder"
 239                        "Name" ,(lisp-implementation-version))
 240           ("Directory" ("Id" "INSTALLDIR")
 241            ("Component" ("Id" "SBCL_SetHOME"
 242                          "Guid" ,(make-guid)
 243                          "DiskId" 1
 244                          #+x86-64 "Win64" #+x86-64 "yes")
 245             ("CreateFolder")
 246             ("Environment" ("Id" "Env_SBCL_HOME"
 247                             "System" "yes"
 248                             "Action" "set"
 249                             "Name" "SBCL_HOME"
 250                             "Part" "all"
 251                             "Value" "[INSTALLDIR]")))
 252
 253            ("Component" ("Id" "SBCL_SetPATH"
 254                          "Guid" ,(make-guid)
 255                          "DiskId" 1
 256                          #+x86-64 "Win64" #+x86-64 "yes")
 257             ("CreateFolder")
 258             ("Environment" ("Id" "Env_PATH"
 259                             "System" "yes"
 260                             "Action" "set"
 261                             "Name" "PATH"
 262                             "Part" "last"
 263                             "Value" "[INSTALLDIR]")))
 264            ("Component" ("Id" "SBCL_Base"
 265                          "Guid" ,(make-guid)
 266                          "DiskId" 1
 267                          #+x86-64 "Win64" #+x86-64 "yes")
 268             ;; If we want to associate files with SBCL, this
 269             ;; is how it's done -- but doing this by default
 270             ;; and without asking the user for permission Is
 271             ;; Bad. Before this is enabled we need to figure out
 272             ;; how to make WiX ask for permission for this...
 273             ;; ,(make-extension "fasl" "application/x-lisp-fasl")
 274             ;; ,(make-extension "lisp" "text/x-lisp-source")
 275             ("File" ("Name" "sbcl.core"
 276                      "Source" "sbcl.core"))
 277             ("File" ("Name" "sbcl.exe"
 278                      "Source" "../src/runtime/sbcl.exe"
 279                      "KeyPath" "yes")
 280                     ("Shortcut" ("Id" "sbcl.lnk"
 281                                  "Advertise" "yes"
 282                                  "Name" ,(application-name/version+machine-type)
 283                                  "Directory" "ProgramMenuDir"
 284                                  "Arguments" "--core \"[#sbcl.core]\""))))
 285            ,@(collect-contrib-components))))))
 286       ("Feature" ("Id" "Minimal"
 287                   "Title" "SBCL Executable"
 288                   "ConfigurableDirectory" "INSTALLDIR"
 289                   "Level" 1)
 290        ("ComponentRef" ("Id" "SBCL_Base"))
 291        ("ComponentRef" ("Id" "ProgramMenuDir"))
 292        ("Feature" ("Id" "Contrib" "Level" 1 "Title" "Contributed Modules")
 293                   ,@(ref-all-components))
 294        ("Feature" ("Id" "SetPath" "Level" 1 "Title" "Set Environment Variable: PATH")
 295                   ("ComponentRef" ("Id" "SBCL_SetPATH")))
 296        ;; SetHome is still enabled by default (level 1), because SBCL
 297        ;; does not yet support running without SBCL_HOME:
 298        ("Feature" ("Id" "SetHome" "Level" 1 "Title" "Set Environment Variable: SBCL_HOME")
 299                   ("ComponentRef" ("Id" "SBCL_SetHOME"))))
 300       ("WixVariable" ("Id" "WixUILicenseRtf"
 301                       "Value" "License.rtf"))
 302       ("Property" ("Id" "WIXUI_INSTALLDIR" "Value" "INSTALLDIR"))
 303       ("UIRef" ("Id" "WixUI_FeatureTree"))))))