[Sbcl-commits] CVS: sbcl/tools-for-build rtf.lisp,NONE,1.1 wxs.lisp,NONE,1.1

[Nikodemus S. <de...@us...>]

Update of /cvsroot/sbcl/sbcl/tools-for-build
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv15418/tools-for-build

Added Files:
	rtf.lisp wxs.lisp 
Log Message:
0.9.13.16: preliminary Windows installer builder
 * Added "free software & no warranty" summary to top of COPYING.

 * tools-for-build/rtf.lisp turns COPYING into License.rtf needed
   for the installer.

 * tools-for-build/wxs.lisp generates the XML from which
   the installer is built.

 * refactor good-for-lisp pathname logic from make-target-contrib.sh
   to sbcl-pwd.sh.

 * make-windows-installer.sh builds sbcl.msi into output/,
   assuming WiX (2.0) is installed in $PROGRAMFILES/WiX or
   $WIX_PATH.
 
   The installer installs sbcl.exe, sbcl.core, and contribs
   into $PROGRAMFILES/Steel Bank Common Lisp/<sbcl-version>/
   by default, though the location is configurable.

   .lisp and .fasl files are associated with the installed
   SBCL, action being to start SBCL and load the file.

   The installation directory is added to PATH.

   SBCL_HOME is set to the installation directory.

   A shortcut is added to the start-menu. The shortcut refers
   to the core explicitly, and will continue to work even if
   a newer SBCL is installed.


--- NEW FILE: rtf.lisp ---
;;;; Generate RTF out of a regular text file, splitting
;;;; paragraphs on empty lines.
;;;;
;;;; Used to generate License.rtf out of COPYING for the
;;;; Windows installer.

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(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~%~}}~%"
                         pars)))

--- NEW FILE: wxs.lisp ---
;;;; Generate WiX XML Source, from which we eventually generate the .MSI

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

;;;; XML generation

(defvar *indent-level* 0)

(defun print-xml (sexp &optional (stream *standard-output*))
  (destructuring-bind (tag &optional attributes &body children) sexp
    (when attributes (assert (evenp (length attributes))))
    (format stream "~VT<~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 "~VT</~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 ()
  (format nil "SBCL ~A" (lisp-implementation-version)))

;;;; 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-long)
            (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))))

(defun list-all-contribs ()
  (loop for flag in (directory "../contrib/*/test-passed")
        collect (car (last (pathname-directory flag)))))

(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.
  (nsubstitute #\_ #\-
               (nsubstitute #\. #\:
                            (nsubstitute #\. #\/
                                         (substitute #\. #\\ string)))))

(defun directory-id (name)
  (id (format nil "Directory_~A" (enough-namestring name))))

(defun directory-names (pathname)
  (let ((name (car (last (pathname-directory pathname)))))
    (if (< 8 (length name))
        (list "Name" (subseq name 0 8)
              "LongName" name)
        (list "Name" name))))

(defun file-id (pathname)
  (id (format nil "File_~A" (enough-namestring pathname))))

(defparameter *ignored-directories* '("CVS" ".svn"))

(defparameter *pathname-type-abbrevs*
  '(("lisp" . "lsp")
    ("fasl" . "fas")
    ("SBCL" . "txt") ; README.SBCL -> README.txt
    ("texinfo" . "tfo")
    ("lisp-temp" . "lmp")))

(defun file-names (pathname)
  (if (or (< 8 (length (pathname-name pathname)))
          (< 3 (length (pathname-type pathname))))
      (let ((short-name (let ((name (pathname-name pathname)))
                          (if (< 8 (length name))
                              (subseq name 0 8)
                              name)))
            (short-type (let ((type (pathname-type pathname)))
                          (if (< 3 (length type))
                              (or (cdr (assoc type *pathname-type-abbrevs* :test #'equalp))
                                  (error "No abbreviation for type: ~A" type))
                              type))))
        (list "Name" (if short-type
                         (format nil "~A.~A" short-name short-type)
                         short-name)
              "LongName" (file-namestring pathname)))
      (list "Name" (file-namestring pathname))))

(defparameter *components* nil)

(defun component-id (pathname)
  (let ((id (id (format nil "Contrib_~A" (enough-namestring pathname)))))
    (push id *components*)
    id))

(defun ref-all-components ()
  (prog1
      (mapcar (lambda (id)
                `("ComponentRef" ("Id" ,id)))
              *components*)
    (setf *components* nil)))

(defun collect-1-component (root)
  `("Directory" ("Id" ,(directory-id root)
                 ,@(directory-names root))
    ("Component" ("Id" ,(component-id root)
                  "Guid" ,(make-guid)
                  "DiskId" 1)
     ,@(loop for file in (directory
                          (make-pathname :name :wild :type :wild :defaults root))
             when (or (pathname-name file) (pathname-type file))
             collect `("File" ("Id" ,(file-id file)
                               ,@(file-names file)
                               "Source" ,(enough-namestring file)))))))

(defun collect-components (root)
  (cons (collect-1-component root)
        (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))))

(defun collect-contrib-components ()
  (loop for contrib in (directory "../contrib/*/test-passed")
        append (collect-components (make-pathname :name nil
                                                  :type nil
                                                  :version nil
                                                  :defaults 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/2003/01/wi")
     ("Product" ("Id" "????????-????-????-????-????????????"
                 "Name" ,(application-name)
                 "Version" ,(lisp-implementation-version)
                 "Manufacturer" "http://www.sbcl.org"
                 "Language" 1033)
      ("Package" ("Id" "????????-????-????-????-????????????"
                  "Manufacturer" "http://www.sbcl.org"
                  "InstallerVersion" 200
                  "Compressed" "yes"))
      ("Media" ("Id" 1
                "Cabinet" "sbcl.cab"
                "EmbedCab" "yes"))
      ("Directory" ("Id" "TARGETDIR"
                    "Name" "SourceDir")
       ("Directory" ("Id" "ProgramMenuFolder"
                     "Name" "PMFolder"))
       ("Directory" ("Id" "ProgramFilesFolder"
                     "Name" "PFiles")
        ("Directory" ("Id" "BaseFolder"
                      "Name" "SBCL"
                      "LongName" "Steel Bank Common Lisp")
         ("Directory" ("Id" "VersionFolder"
                       "Name" ,(lisp-implementation-version))
          ("Directory" ("Id" "INSTALLDIR")
           ("Component" ("Id" "SBCL_Base"
                         "Guid" ,(make-guid)
                         "DiskId" 1)
            ("Environment" ("Id" "Env_SBCL_HOME"
                            "Action" "set"
                            "Name" "SBCL_HOME"
                            "Part" "all"
                            "Value" "[INSTALLDIR]"))
            ("Environment" ("Id" "Env_PATH"
                            "Action" "set"
                            "Name" "PATH"
                            "Part" "first"
                            "Value" "[INSTALLDIR]"))
            ,(make-extension "fasl" "application/x-lisp-fasl")
            ,(make-extension "lisp" "text/x-lisp-source")
            ("File" ("Id" "sbcl.exe"
                     "Name" "sbcl.exe"
                     "Source" "../src/runtime/sbcl.exe")
             ("Shortcut" ("Id" "sbcl.lnk"
                          "Directory" "ProgramMenuFolder"
                          "Name" "SBCL"
                          "LongName" ,(application-name)
                          "Arguments" "--core \"[#sbcl.core]\"")))
            ("File" ("Id" "sbcl.core"
                     "Name" "sbcl.cre"
                     "LongName" "sbcl.core"
                     "Source" "sbcl.core")))
           ,@(collect-contrib-components))))))
      ("Feature" ("Id" "Minimal"
                  "ConfigurableDirectory" "INSTALLDIR"
                  "Level" 1)
       ("ComponentRef" ("Id" "SBCL_Base"))
       ,@(ref-all-components))
      ("Property" ("Id" "WIXUI_INSTALLDIR" "Value" "INSTALLDIR"))
      ("UIRef" ("Id" "WixUI_InstallDir"))))))