1.0.35.12: Minor cleanup in %TARGET-DEFSTRUCT.
[sbcl.git] / 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     ("html" . "htm")))
121
122 (defun file-names (pathname)
123   (if (or (< 8 (length (pathname-name pathname)))
124           (< 3 (length (pathname-type pathname))))
125       (let ((short-name (let ((name (pathname-name pathname)))
126                           (if (< 8 (length name))
127                               (subseq name 0 8)
128                               name)))
129             (short-type (let ((type (pathname-type pathname)))
130                           (if (< 3 (length type))
131                               (or (cdr (assoc type *pathname-type-abbrevs* :test #'equalp))
132                                   (error "No abbreviation for type: ~A" type))
133                               type))))
134         (list "Name" (if short-type
135                          (format nil "~A.~A" short-name short-type)
136                          short-name)
137               "LongName" (file-namestring pathname)))
138       (list "Name" (file-namestring pathname))))
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" ("Id" ,(directory-id root)
156                  ,@(directory-names root))
157     ("Component" ("Id" ,(component-id root)
158                   "Guid" ,(make-guid)
159                   "DiskId" 1)
160      ,@(loop for file in (directory
161                           (make-pathname :name :wild :type :wild :defaults root))
162              when (or (pathname-name file) (pathname-type file))
163              collect `("File" ("Id" ,(file-id file)
164                                ,@(file-names file)
165                                "Source" ,(enough-namestring file)))))))
166
167 (defun collect-components (root)
168   (cons (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   (loop for contrib in (directory "../contrib/*/test-passed")
181         append (collect-components (make-pathname :name nil
182                                                   :type nil
183                                                   :version nil
184                                                   :defaults contrib))))
185
186 (defun make-extension (type mime)
187   `("Extension" ("Id" ,type "ContentType" ,mime)
188     ("Verb" ("Id" ,(format nil "load_~A" type)
189              "Argument" "--core \"[#sbcl.core]\" --load \"%1\""
190              "Command" "Load with SBCL"
191              "Target" "[#sbcl.exe]"))))
192
193 (defun write-wxs (pathname)
194   ;; both :INVERT and :PRESERVE could be used here, but this seemed
195   ;; better at the time
196   (xml-1.0
197    pathname
198    `("Wix" ("xmlns" "http://schemas.microsoft.com/wix/2003/01/wi")
199      ("Product" ("Id" "????????-????-????-????-????????????"
200                  "Name" ,(application-name)
201                  "Version" ,(lisp-implementation-version)
202                  "Manufacturer" "http://www.sbcl.org"
203                  "Language" 1033)
204       ("Package" ("Id" "????????-????-????-????-????????????"
205                   "Manufacturer" "http://www.sbcl.org"
206                   "InstallerVersion" 200
207                   "Compressed" "yes"))
208       ("Media" ("Id" 1
209                 "Cabinet" "sbcl.cab"
210                 "EmbedCab" "yes"))
211       ("Directory" ("Id" "TARGETDIR"
212                     "Name" "SourceDir")
213        ("Directory" ("Id" "ProgramMenuFolder"
214                      "Name" "PMFolder"))
215        ("Directory" ("Id" "ProgramFilesFolder"
216                      "Name" "PFiles")
217         ("Directory" ("Id" "BaseFolder"
218                       "Name" "SBCL"
219                       "LongName" "Steel Bank Common Lisp")
220          ("Directory" ("Id" "VersionFolder"
221                        "Name" ,(lisp-implementation-version))
222           ("Directory" ("Id" "INSTALLDIR")
223            ("Component" ("Id" "SBCL_Base"
224                          "Guid" ,(make-guid)
225                          "DiskId" 1)
226             ("Environment" ("Id" "Env_SBCL_HOME"
227                             "Action" "set"
228                             "Name" "SBCL_HOME"
229                             "Part" "all"
230                             "Value" "[INSTALLDIR]"))
231             ("Environment" ("Id" "Env_PATH"
232                             "Action" "set"
233                             "Name" "PATH"
234                             "Part" "first"
235                             "Value" "[INSTALLDIR]"))
236             ;; If we want to associate files with SBCL, this
237             ;; is how it's done -- but doing this by default
238             ;; and without asking the user for permission Is
239             ;; Bad. Before this is enabled we need to figure out
240             ;; how to make WiX ask for permission for this...
241             ;; ,(make-extension "fasl" "application/x-lisp-fasl")
242             ;; ,(make-extension "lisp" "text/x-lisp-source")
243             ("File" ("Id" "sbcl.exe"
244                      "Name" "sbcl.exe"
245                      "Source" "../src/runtime/sbcl.exe")
246              ("Shortcut" ("Id" "sbcl.lnk"
247                           "Directory" "ProgramMenuFolder"
248                           "Name" "SBCL"
249                           "LongName" ,(application-name)
250                           "Arguments" "--core \"[#sbcl.core]\"")))
251             ("File" ("Id" "sbcl.core"
252                      "Name" "sbcl.cre"
253                      "LongName" "sbcl.core"
254                      "Source" "sbcl.core")))
255            ,@(collect-contrib-components))))))
256       ("Feature" ("Id" "Minimal"
257                   "ConfigurableDirectory" "INSTALLDIR"
258                   "Level" 1)
259        ("ComponentRef" ("Id" "SBCL_Base"))
260        ,@(ref-all-components))
261       ("Property" ("Id" "WIXUI_INSTALLDIR" "Value" "INSTALLDIR"))
262       ("UIRef" ("Id" "WixUI_InstallDir"))))))