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