1 ;;;; Generate WiX XML Source, from which we eventually generate the .MSI
3 ;;;; This software is part of the SBCL system. See the README file for
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.
14 (defvar *indent-level* 0)
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)
24 (error "Malformed child: ~S in ~S" child children))
25 (print-xml child stream)))
27 (format stream "~VT</~A>~%" *indent-level* tag))))
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)))
35 (defun application-name ()
36 (format nil "SBCL ~A" (lisp-implementation-version)))
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.
44 ;;;; Something to twiddle on a rainy day, I think.
46 (load-shared-object "OLE32.DLL")
48 (define-alien-type uuid
51 (data2 unsigned-short)
52 (data3 unsigned-short)
53 (data4 (array unsigned-char 8))))
55 (define-alien-routine ("CoCreateGuid" co-create-guid) int (guid (* uuid)))
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~}"
66 (loop for i from 2 upto 7 collect (deref data4 i)))))
72 (setf guid (make-alien (struct uuid)))
77 (defun list-all-contribs ()
78 (loop for flag in (directory "../contrib/*/test-passed")
79 collect (car (last (pathname-directory flag)))))
81 (defvar *id-char-substitutions* '((#\\ . #\_)
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*))
94 (defun directory-id (name)
95 (id (format nil "Directory_~A" (enough-namestring name))))
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)
102 (list "Name" name))))
104 (defun file-id (pathname)
105 (id (format nil "File_~A" (enough-namestring pathname))))
107 (defparameter *ignored-directories* '("CVS" ".svn"))
109 (defparameter *pathname-type-abbrevs*
112 ("SBCL" . "txt") ; README.SBCL -> README.txt
114 ("lisp-temp" . "lmp")))
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))
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))
128 (list "Name" (if short-type
129 (format nil "~A.~A" short-name short-type)
131 "LongName" (file-namestring pathname)))
132 (list "Name" (file-namestring pathname))))
134 (defparameter *components* nil)
136 (defun component-id (pathname)
137 (let ((id (id (format nil "Contrib_~A" (enough-namestring pathname)))))
138 (push id *components*)
141 (defun ref-all-components ()
144 `("ComponentRef" ("Id" ,id)))
146 (setf *components* nil)))
148 (defun collect-1-component (root)
149 `("Directory" ("Id" ,(directory-id root)
150 ,@(directory-names root))
151 ("Component" ("Id" ,(component-id root)
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)
159 "Source" ,(enough-namestring file)))))))
161 (defun collect-components (root)
162 (cons (collect-1-component root)
163 (loop for directory in
165 (merge-pathnames (make-pathname
166 :directory '(:relative :wild)
169 unless (member (car (last (pathname-directory directory)))
170 *ignored-directories* :test #'equal)
171 append (collect-components directory))))
173 (defun collect-contrib-components ()
174 (loop for contrib in (directory "../contrib/*/test-passed")
175 append (collect-components (make-pathname :name nil
178 :defaults contrib))))
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]"))))
187 (defun write-wxs (pathname)
188 ;; both :INVERT and :PRESERVE could be used here, but this seemed
189 ;; better at the time
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"
198 ("Package" ("Id" "????????-????-????-????-????????????"
199 "Manufacturer" "http://www.sbcl.org"
200 "InstallerVersion" 200
205 ("Directory" ("Id" "TARGETDIR"
207 ("Directory" ("Id" "ProgramMenuFolder"
209 ("Directory" ("Id" "ProgramFilesFolder"
211 ("Directory" ("Id" "BaseFolder"
213 "LongName" "Steel Bank Common Lisp")
214 ("Directory" ("Id" "VersionFolder"
215 "Name" ,(lisp-implementation-version))
216 ("Directory" ("Id" "INSTALLDIR")
217 ("Component" ("Id" "SBCL_Base"
220 ("Environment" ("Id" "Env_SBCL_HOME"
224 "Value" "[INSTALLDIR]"))
225 ("Environment" ("Id" "Env_PATH"
229 "Value" "[INSTALLDIR]"))
230 ,(make-extension "fasl" "application/x-lisp-fasl")
231 ,(make-extension "lisp" "text/x-lisp-source")
232 ("File" ("Id" "sbcl.exe"
234 "Source" "../src/runtime/sbcl.exe")
235 ("Shortcut" ("Id" "sbcl.lnk"
236 "Directory" "ProgramMenuFolder"
238 "LongName" ,(application-name)
239 "Arguments" "--core \"[#sbcl.core]\"")))
240 ("File" ("Id" "sbcl.core"
242 "LongName" "sbcl.core"
243 "Source" "sbcl.core")))
244 ,@(collect-contrib-components))))))
245 ("Feature" ("Id" "Minimal"
246 "ConfigurableDirectory" "INSTALLDIR"
248 ("ComponentRef" ("Id" "SBCL_Base"))
249 ,@(ref-all-components))
250 ("Property" ("Id" "WIXUI_INSTALLDIR" "Value" "INSTALLDIR"))
251 ("UIRef" ("Id" "WixUI_InstallDir"))))))