copied from sbcl...

scripts/wxs.ros

@@ -1,10 +1,334 @@
 #!/bin/sh
 #|-*- mode:lisp -*-|#
 #|
-exec ros -Q -- $0 "$@"
+exec ros -L sbcl-bin -Q -- $0 "$@"
 |#
+
+;;;; Generate WiX XML Source, from which we eventually generate the .MSI
+;;;; This software is derived from the sbcl.
+
 (defpackage :ros.script.wxs.3661242446
-  (:use :cl))
+  (:use :cl :sb-alien))
 (in-package :ros.script.wxs.3661242446)
+
+(defvar *indent-level* 0)
+
+(defvar *source-root*
+  (truename
+   (merge-pathnames (make-pathname :directory (list :relative :up))
+                    (make-pathname :name nil :type nil :defaults *load-truename*))))
+
+(defun print-xml (sexp &optional (stream *standard-output*))
+  (destructuring-bind (tag &optional attributes &body children) sexp
+    (when attributes (assert (evenp (length attributes))))
+    (format stream "~V@T<~A~{ ~A='~A'~}~@[/~]>~%"
+            *indent-level* tag attributes (not children))
+    (let ((*indent-level* (+ *indent-level* 3)))
+      (dolist (child children)
+        (unless (listp child)
+          (error "Malformed child: ~S in ~S" child children))
+        (print-xml child stream)))
+    (when children
+      (format stream "~V@T</~A>~%" *indent-level* tag))))
+
+(defun xml-1.0 (pathname sexp)
+  (with-open-file (xml pathname :direction :output :if-exists :supersede
+                       :external-format :ascii)
+     (format xml "<?xml version='1.0'?>~%")
+     (print-xml sexp xml)))
+
+(defun application-name ()
+  "Roswell")
+
+(defun application-name/version+machine-type ()
+  (format nil "~A ~A (~A)"
+          (application-name) (ros:version) (machine-type)))
+
+(defun manufacturer-name ()
+  "https://github.com/roswell/roswell")
+
+(defun upgrade-code ()
+  "443BD981-804A-4964-9CAB-116C4686D13E")
+
+(defun version-digits (&optional (horrible-thing (ros:version)))
+  "Turns something like 0.pre7.14.flaky4.13 (see version.lisp-expr)
+  into an acceptable form for WIX (up to four dot-separated numbers)."
+  (with-output-to-string (output)
+    (loop repeat 4
+          with position = 0
+          for separator = "" then "."
+          for next-digit = (position-if #'digit-char-p horrible-thing
+                                    :start position)
+          while next-digit
+          do (multiple-value-bind (number end)
+                 (parse-integer horrible-thing :start next-digit :junk-allowed t)
+               (format output "~A~D" separator number)
+               (setf position end)))))
+
+;;;; GUID generation
+;;;;
+;;;; Apparently this willy-nilly regeneration of GUIDs is a bad thing, and
+;;;; we should probably have a single GUID per release / Component, so
+;;;; that no matter by whom the .MSI is built the GUIDs are the same.
+;;;;
+;;;; Something to twiddle on a rainy day, I think.
+
+(load-shared-object "OLE32.DLL")
+
+(define-alien-type uuid
+    (struct uuid
+            (data1 unsigned-int)
+            (data2 unsigned-short)
+            (data3 unsigned-short)
+            (data4 (array unsigned-char 8))))
+
+(define-alien-routine ("CoCreateGuid" co-create-guid) int (guid (* uuid)))
+
+(defun uuid-string (uuid)
+  (declare (type (alien (* uuid)) uuid))
+  (let ((data4 (slot uuid 'data4)))
+    (format nil "~8,'0X-~4,'0X-~4,'0X-~2,'0X~2,'0X-~{~2,'0X~}"
+            (slot uuid 'data1)
+            (slot uuid 'data2)
+            (slot uuid 'data3)
+            (deref data4 0)
+            (deref data4 1)
+            (loop for i from 2 upto 7 collect (deref data4 i)))))
+
+(defun make-guid ()
+  (let (guid)
+    (unwind-protect
+         (progn
+           (setf guid (make-alien (struct uuid)))
+           (co-create-guid guid)
+           (uuid-string guid))
+      (free-alien guid))))
+
+(defvar *id-char-substitutions* '((#\\ . #\_)
+                                  (#\/ . #\_)
+                                  (#\: . #\.)
+                                  (#\- . #\.)
+				  (#\+ . #\.)
+				  (#\% . #\.)))
+(defun id (string)
+  ;; Mangle a string till it can be used as an Id. A-Z, a-z, 0-9, and
+  ;; _ are ok, nothing else is.
+  (map 'string (lambda (c)
+                 (or (cdr (assoc c *id-char-substitutions*))
+                     c))
+       string))
+
+(defun directory-id (name)
+  (id (format nil "Directory_~A" (enough-namestring name *source-root*))))
+
+(defun file-id (pathname)
+  (id (format nil "File_~A" (enough-namestring pathname *source-root*))))
+
+(defparameter *ignored-directories* '("CVS" ".svn" "test-output" ".deps"))
+
+(defparameter *components* nil)
+
+(defun component-id (pathname type)
+  (let ((id (id (format nil "~A_~A" type (enough-namestring pathname *source-root*)))))
+    (push id *components*)
+    id))
+
+(defun ref-all-components ()
+  (prog1
+      (mapcar (lambda (id)
+                `("ComponentRef" ("Id" ,id)))
+              *components*)
+    (setf *components* nil)))
+
+(defun collect-1-component (root type)
+  `("Directory" ("Name" ,(car (last (pathname-directory root)))
+                 "Id" ,(directory-id root))
+    ("Component" ("Id" ,(component-id root type)
+                  "Guid" ,(make-guid)
+                  "DiskId" 1
+                  #+x86-64 "Win64" #+x86-64 "yes")
+     ,@(loop for file in (directory
+                          (make-pathname :name :wild :type :wild :defaults root))
+             when (or (pathname-name file) (pathname-type file))
+             collect `("File" ("Name" ,(file-namestring file)
+                               "Id" ,(file-id file)
+                               "Source" ,(enough-namestring file)))))))
+
+(defun directory-empty-p (dir)
+  (null (directory (make-pathname :name :wild :type :wild :defaults dir))))
+
+(defun collect-components (root type)
+  (append (unless (directory-empty-p root) (list (collect-1-component root type)))
+          (loop for directory in
+                (directory
+                 (merge-pathnames (make-pathname
+                                   :directory '(:relative :wild)
+                                   :name nil :type nil)
+                                  root))
+                unless (member (car (last (pathname-directory directory)))
+                               *ignored-directories* :test #'equal)
+                append (collect-components directory "Contrib"))))
+
+(defun collect-contrib-components ()
+  (collect-components "../src/lisp/" "Contrib"))
+
+(defun make-extension (type mime)
+  `("Extension" ("Id" ,type "ContentType" ,mime)
+    ("Verb" ("Id" ,(format nil "load_~A" type)
+             "Argument" "--core \"[#sbcl.core]\" --load \"%1\""
+             "Command" "Load with SBCL"
+             "Target" "[#sbcl.exe]"))))
+
+(defun write-wxs (pathname)
+  ;; both :INVERT and :PRESERVE could be used here, but this seemed
+  ;; better at the time
+  (xml-1.0
+   pathname
+   `("Wix" ("xmlns" "http://schemas.microsoft.com/wix/2006/wi")
+     ("Product" ("Id" "*"
+                 "Name" ,(application-name/version+machine-type)
+                 "Version" ,(version-digits)
+                 "Manufacturer" ,(manufacturer-name)
+                 "UpgradeCode" ,(upgrade-code)
+                 "Language" 1033)
+      ("Package" ("Id" "*"
+                  "Manufacturer" ,(manufacturer-name)
+                  "InstallerVersion" 200
+                  "Compressed" "yes"
+                  #+x86-64 "Platform" #+x86-64 "x64"
+                  "InstallScope" "perMachine"))
+      ("Media" ("Id" 1
+                "Cabinet" "roswell.cab"
+                "EmbedCab" "yes"))
+      ("Property" ("Id" "PREVIOUSVERSIONSINSTALLED"
+                   "Secure" "yes"))
+      ("Upgrade" ("Id" ,(upgrade-code))
+       ("UpgradeVersion" ("Minimum" "1.0.0"
+                          "Maximum" "99.0.0"
+                          "Property" "PREVIOUSVERSIONSINSTALLED"
+                          "IncludeMinimum" "yes"
+                          "IncludeMaximum" "no")))
+      ("InstallExecuteSequence" ()
+       ("RemoveExistingProducts" ("After" "InstallInitialize")))
+      ("Directory" ("Id" "TARGETDIR"
+                    "Name" "SourceDir")
+       ("Directory" ("Id" "ProgramMenuFolder")
+        ("Directory" ("Id" "ProgramMenuDir"
+                      "Name" ,(application-name/version+machine-type))
+         ("Component" ("Id" "ProgramMenuDir"
+                       "Guid" ,(make-guid))
+          ("RemoveFolder" ("Id" "ProgramMenuDir"
+                           "On" "uninstall"))
+          ("RegistryValue" ("Root" "HKCU"
+                            "Key" "Software\\[Manufacturer]\\[ProductName]"
+                            "Type" "string"
+                            "Value" ""
+                            "KeyPath" "yes")))))
+       ("Directory" ("Id" #-x86-64 "ProgramFilesFolder" #+x86-64 "ProgramFiles64Folder"
+                     "Name" "PFiles")
+        ("Directory" ("Id" "BaseFolder"
+                      "Name" ,(application-name))
+         ("Directory" ("Id" "VersionFolder"
+                       "Name" ,(ros:version))
+          ("Directory" ("Id" "INSTALLDIR")
+           #+nil("Component" ("Id" "SBCL_SetHOME"
+                         "Guid" ,(make-guid)
+                         "DiskId" 1
+                         #+x86-64 "Win64" #+x86-64 "yes")
+            ("CreateFolder")
+            ("Environment" ("Id" "Env_SBCL_HOME"
+                            "System" "yes"
+                            "Action" "set"
+                            "Name" "SBCL_HOME"
+                            "Part" "all"
+                            "Value" "[INSTALLDIR]")))
+
+           ("Component" ("Id" "ROSWELL_SetPATH"
+                         "Guid" ,(make-guid)
+                         "DiskId" 1
+                         #+x86-64 "Win64" #+x86-64 "yes")
+            ("CreateFolder")
+            ("Environment" ("Id" "Env_PATH"
+                            "System" "yes"
+                            "Action" "set"
+                            "Name" "PATH"
+                            "Part" "last"
+                            "Value" "[INSTALLDIR]")))
+           ("Component" ("Id" "ROSWELL_Base"
+                         "Guid" ,(make-guid)
+                         "DiskId" 1
+                         #+x86-64 "Win64" #+x86-64 "yes")
+            ;; If we want to associate files with Roswell, this
+            ;; is how it's done -- but doing this by default
+            ;; and without asking the user for permission Is
+            ;; Bad. Before this is enabled we need to figure out
+            ;; how to make WiX ask for permission for this...
+            ;; ,(make-extension "fasl" "application/x-lisp-fasl")
+            ;; ,(make-extension "lisp" "text/x-lisp-source")
+            #+nil("File" ("Name" "sbcl.core"
+                     "Source" "sbcl.core"))
+            ("File" ("Name" "ros.exe"
+                     "Source" "../src/ros.exe"
+                     "KeyPath" "yes")
+                    ("Shortcut" ("Id" "Roswell.lnk"
+                                 "Advertise" "yes"
+                                 "Name" ,(application-name/version+machine-type)
+                                 "Directory" "ProgramMenuDir"
+                                 "Arguments" "run"))))
+           ,@(collect-contrib-components))))))
+      ("Feature" ("Id" "Minimal"
+                  "Title" "Roswell Executable"
+                  "ConfigurableDirectory" "INSTALLDIR"
+                  "Level" 1)
+       ("ComponentRef" ("Id" "ROSWELL_Base"))
+       ("ComponentRef" ("Id" "ProgramMenuDir"))
+       ("Feature" ("Id" "Contrib" "Level" 1 "Title" "Contributed Modules")
+                  ,@(ref-all-components))
+       ("Feature" ("Id" "SetPath" "Level" 1 "Title" "Set Environment Variable: PATH")
+                  ("ComponentRef" ("Id" "ROSWELL_SetPATH")))
+       ;; SetHome is still enabled by default (level 1), because SBCL
+       ;; does not yet support running without SBCL_HOME:
+       #+nil("Feature" ("Id" "SetHome" "Level" 1 "Title" "Set Environment Variable: SBCL_HOME")
+                  ("ComponentRef" ("Id" "SBCL_SetHOME"))))
+      ("WixVariable" ("Id" "WixUILicenseRtf"
+                      "Value" "License.rtf"))
+      ("Property" ("Id" "WIXUI_INSTALLDIR" "Value" "INSTALLDIR"))
+      ("UIRef" ("Id" "WixUI_FeatureTree"))))))
+
+(defun read-text (pathname)
+  (let ((pars (list nil)))
+    (with-open-file (f pathname :external-format :ascii)
+      (loop for line = (read-line f nil)
+            for text = (string-trim '(#\Space #\Tab) line)
+            while line
+            when (plusp (length text))
+            do (setf (car pars)
+                     (if (car pars)
+                         (concatenate 'string (car pars) " " text)
+                         text))
+            else
+            do (push nil pars)))
+    (nreverse pars)))
+
+(defun write-rtf (pars pathname)
+  (with-open-file (f pathname :direction :output :external-format :ascii
+                     :if-exists :supersede)
+    ;; \rtf0 = RTF 1.0
+    ;; \ansi = character set
+    ;; \deffn = default font
+    ;; \fonttbl = font table
+    ;; \fs = font size in half-points
+    (format f "{\\rtf1\\ansi~
+                \\deffn0~
+                {\\fonttbl\\f0\\fswiss Helvetica;}~
+                \\fs20~
+                ~{~A\\par\\par ~}}"      ; each par used to end with
+                                         ; ~%, but resulting Rtf looks
+                                         ; strange (WinXP, WiX 3.0.x,
+                                         ; ?)
+                         pars)))
+
 (defun main (&rest argv)
-  (declare (ignorable argv)))
+  (declare (ignorable argv))
+  (write-rtf (read-text "../COPYING") "License.rtf")
+  (write-wxs "roswell.wxs"))