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