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 "~VT<~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 "~VT</~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   (format nil "SBCL ~A" (lisp-implementation-version)))
  42
  43 ;;;; GUID generation
  44 ;;;;
  45 ;;;; Apparently this willy-nilly regeneration of GUIDs is a bad thing, and
  46 ;;;; we should probably have a single GUID per release / Component, so
  47 ;;;; that no matter by whom the .MSI is built the GUIDs are the same.
  48 ;;;;
  49 ;;;; Something to twiddle on a rainy day, I think.
  50
  51 (load-shared-object "OLE32.DLL")
  52
  53 (define-alien-type uuid
  54     (struct uuid
  55             (data1 unsigned-long)
  56             (data2 unsigned-short)
  57             (data3 unsigned-short)
  58             (data4 (array unsigned-char 8))))
  59
  60 (define-alien-routine ("CoCreateGuid" co-create-guid) int (guid (* uuid)))
  61
  62 (defun uuid-string (uuid)
  63   (declare (type (alien (* uuid)) uuid))
  64   (let ((data4 (slot uuid 'data4)))
  65     (format nil "~8,'0X-~4,'0X-~4,'0X-~2,'0X~2,'0X-~{~2,'0X~}"
  66             (slot uuid 'data1)
  67             (slot uuid 'data2)
  68             (slot uuid 'data3)
  69             (deref data4 0)
  70             (deref data4 1)
  71             (loop for i from 2 upto 7 collect (deref data4 i)))))
  72
  73 (defun make-guid ()
  74   (let (guid)
  75     (unwind-protect
  76          (progn
  77            (setf guid (make-alien (struct uuid)))
  78            (co-create-guid guid)
  79            (uuid-string guid))
  80       (free-alien guid))))
  81
  82 (defun list-all-contribs ()
  83   (loop for flag in (directory "../contrib/*/test-passed")
  84         collect (car (last (pathname-directory flag)))))
  85
  86 (defvar *id-char-substitutions* '((#\\ . #\_)
  87                                   (#\/ . #\_)
  88                                   (#\: . #\.)
  89                                   (#\- . #\.)))
  90
  91 (defun id (string)
  92   ;; Mangle a string till it can be used as an Id. A-Z, a-z, 0-9, and
  93   ;; _ are ok, nothing else is.
  94   (map 'string (lambda (c)
  95                  (or (cdr (assoc c *id-char-substitutions*))
  96                      c))
  97        string))
  98
  99 (defun directory-id (name)
 100   (id (format nil "Directory_~A" (enough-namestring name *sbcl-source-root*))))
 101
 102 (defun directory-names (pathname)
 103   (let ((name (car (last (pathname-directory pathname)))))
 104     (if (< 8 (length name))
 105         (list "Name" (subseq name 0 8)
 106               "LongName" name)
 107         (list "Name" name))))
 108
 109 (defun file-id (pathname)
 110   (id (format nil "File_~A" (enough-namestring pathname *sbcl-source-root*))))
 111
 112 (defparameter *ignored-directories* '("CVS" ".svn"))
 113
 114 (defparameter *pathname-type-abbrevs*
 115   '(("lisp" . "lsp")
 116     ("fasl" . "fas")
 117     ("SBCL" . "txt") ; README.SBCL -> README.txt
 118     ("texinfo" . "tfo")
 119     ("lisp-temp" . "lmp")))
 120
 121 (defun file-names (pathname)
 122   (if (or (< 8 (length (pathname-name pathname)))
 123           (< 3 (length (pathname-type pathname))))
 124       (let ((short-name (let ((name (pathname-name pathname)))
 125                           (if (< 8 (length name))
 126                               (subseq name 0 8)
 127                               name)))
 128             (short-type (let ((type (pathname-type pathname)))
 129                           (if (< 3 (length type))
 130                               (or (cdr (assoc type *pathname-type-abbrevs* :test #'equalp))
 131                                   (error "No abbreviation for type: ~A" type))
 132                               type))))
 133         (list "Name" (if short-type
 134                          (format nil "~A.~A" short-name short-type)
 135                          short-name)
 136               "LongName" (file-namestring pathname)))
 137       (list "Name" (file-namestring pathname))))
 138
 139 (defparameter *components* nil)
 140
 141 (defun component-id (pathname)
 142   (let ((id (id (format nil "Contrib_~A" (enough-namestring pathname *sbcl-source-root*)))))
 143     (push id *components*)
 144     id))
 145
 146 (defun ref-all-components ()
 147   (prog1
 148       (mapcar (lambda (id)
 149                 `("ComponentRef" ("Id" ,id)))
 150               *components*)
 151     (setf *components* nil)))
 152
 153 (defun collect-1-component (root)
 154   `("Directory" ("Id" ,(directory-id root)
 155                  ,@(directory-names root))
 156     ("Component" ("Id" ,(component-id root)
 157                   "Guid" ,(make-guid)
 158                   "DiskId" 1)
 159      ,@(loop for file in (directory
 160                           (make-pathname :name :wild :type :wild :defaults root))
 161              when (or (pathname-name file) (pathname-type file))
 162              collect `("File" ("Id" ,(file-id file)
 163                                ,@(file-names file)
 164                                "Source" ,(enough-namestring file)))))))
 165
 166 (defun collect-components (root)
 167   (cons (collect-1-component root)
 168         (loop for directory in
 169               (directory
 170                (merge-pathnames (make-pathname
 171                                  :directory '(:relative :wild)
 172                                  :name nil :type nil)
 173                                 root))
 174               unless (member (car (last (pathname-directory directory)))
 175                              *ignored-directories* :test #'equal)
 176               append (collect-components directory))))
 177
 178 (defun collect-contrib-components ()
 179   (loop for contrib in (directory "../contrib/*/test-passed")
 180         append (collect-components (make-pathname :name nil
 181                                                   :type nil
 182                                                   :version nil
 183                                                   :defaults contrib))))
 184
 185 (defun make-extension (type mime)
 186   `("Extension" ("Id" ,type "ContentType" ,mime)
 187     ("Verb" ("Id" ,(format nil "load_~A" type)
 188              "Argument" "--core \"[#sbcl.core]\" --load \"%1\""
 189              "Command" "Load with SBCL"
 190              "Target" "[#sbcl.exe]"))))
 191
 192 (defun write-wxs (pathname)
 193   ;; both :INVERT and :PRESERVE could be used here, but this seemed
 194   ;; better at the time
 195   (xml-1.0
 196    pathname
 197    `("Wix" ("xmlns" "http://schemas.microsoft.com/wix/2003/01/wi")
 198      ("Product" ("Id" "????????-????-????-????-????????????"
 199                  "Name" ,(application-name)
 200                  "Version" ,(lisp-implementation-version)
 201                  "Manufacturer" "http://www.sbcl.org"
 202                  "Language" 1033)
 203       ("Package" ("Id" "????????-????-????-????-????????????"
 204                   "Manufacturer" "http://www.sbcl.org"
 205                   "InstallerVersion" 200
 206                   "Compressed" "yes"))
 207       ("Media" ("Id" 1
 208                 "Cabinet" "sbcl.cab"
 209                 "EmbedCab" "yes"))
 210       ("Directory" ("Id" "TARGETDIR"
 211                     "Name" "SourceDir")
 212        ("Directory" ("Id" "ProgramMenuFolder"
 213                      "Name" "PMFolder"))
 214        ("Directory" ("Id" "ProgramFilesFolder"
 215                      "Name" "PFiles")
 216         ("Directory" ("Id" "BaseFolder"
 217                       "Name" "SBCL"
 218                       "LongName" "Steel Bank Common Lisp")
 219          ("Directory" ("Id" "VersionFolder"
 220                        "Name" ,(lisp-implementation-version))
 221           ("Directory" ("Id" "INSTALLDIR")
 222            ("Component" ("Id" "SBCL_Base"
 223                          "Guid" ,(make-guid)
 224                          "DiskId" 1)
 225             ("Environment" ("Id" "Env_SBCL_HOME"
 226                             "Action" "set"
 227                             "Name" "SBCL_HOME"
 228                             "Part" "all"
 229                             "Value" "[INSTALLDIR]"))
 230             ("Environment" ("Id" "Env_PATH"
 231                             "Action" "set"
 232                             "Name" "PATH"
 233                             "Part" "first"
 234                             "Value" "[INSTALLDIR]"))
 235             ,(make-extension "fasl" "application/x-lisp-fasl")
 236             ,(make-extension "lisp" "text/x-lisp-source")
 237             ("File" ("Id" "sbcl.exe"
 238                      "Name" "sbcl.exe"
 239                      "Source" "../src/runtime/sbcl.exe")
 240              ("Shortcut" ("Id" "sbcl.lnk"
 241                           "Directory" "ProgramMenuFolder"
 242                           "Name" "SBCL"
 243                           "LongName" ,(application-name)
 244                           "Arguments" "--core \"[#sbcl.core]\"")))
 245             ("File" ("Id" "sbcl.core"
 246                      "Name" "sbcl.cre"
 247                      "LongName" "sbcl.core"
 248                      "Source" "sbcl.core")))
 249            ,@(collect-contrib-components))))))
 250       ("Feature" ("Id" "Minimal"
 251                   "ConfigurableDirectory" "INSTALLDIR"
 252                   "Level" 1)
 253        ("ComponentRef" ("Id" "SBCL_Base"))
 254        ,@(ref-all-components))
 255       ("Property" ("Id" "WIXUI_INSTALLDIR" "Value" "INSTALLDIR"))
 256       ("UIRef" ("Id" "WixUI_InstallDir"))))))