mirror of
https://github.com/roswell/roswell.git
synced 2026-09-10 07:16:17 -04:00
335 lines
13 KiB
Common Lisp
Executable file
335 lines
13 KiB
Common Lisp
Executable file
#!/bin/sh
|
|
#|-*- mode:lisp -*-|#
|
|
#|
|
|
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 :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))
|
|
(write-rtf (read-text "../COPYING") "License.rtf")
|
|
(write-wxs "roswell.wxs"))
|