Commit e4ebda80 authored by Eric Timmons's avatar Eric Timmons
Browse files

Fix WXS script to include all CLPM source code

parent 181c2304
Loading
Loading
Loading
Loading
Loading
+143 −122
Original line number Diff line number Diff line
@@ -15,27 +15,43 @@
(setup-asdf "default")

(asdf:load-system :s-xml)
(asdf:load-system :uuid)

(defun directory-tree (pn file-base-id dir-base-id)
  (let ((files (directory (merge-pathnames "*.*" pn)))
(defun gen-uuid ()
  (format nil "~A" (uuid:make-v4-uuid)))

(defun sanitize-id (id)
  (substitute #\_ #\- id))

(defun directory-tree (pn component-base-id file-base-id dir-base-id)
  (let* ((files (directory (merge-pathnames "*.*" pn)))
         (dirs (directory (merge-pathnames "*/" pn)))
        (out nil))
         (dir-name (car (last (pathname-directory pn))))
         (dir-id (uiop:strcat dir-base-id "." dir-name))
         (out `(("Directory" "Name" ,dir-name "Id" ,(sanitize-id dir-id))))
         (component-name (sanitize-id (uiop:strcat component-base-id "_" dir-name)))
         (component-names (list component-name))
         (component (list (list (list "CreateFolder"))
                          (list "Component"
                                "Id" component-name
                                "Guid" (gen-uuid)
                                "DiskId" "1"
                                "Win64" "yes"))))
    (dolist (file files)
      (unless (or (uiop:directory-pathname-p file)
                  (equal "fasl" (pathname-type file)))
        (let ((enough (enough-namestring file pn)))
          (push `(("File" "Name" ,enough
                          "Id" ,(uiop:strcat file-base-id "." enough)
                          "Id" ,(sanitize-id (uiop:strcat file-base-id "." dir-name "." enough))
                          "Source" ,(enough-namestring file *build-root-pathname*)))
                out))))
                component))))
    (push (nreverse component) out)
    (dolist (dir dirs)
      (let ((name (car (last (pathname-directory dir)))))
        (push `(("Directory" "Name" ,name
                             "Id" ,(uiop:strcat dir-base-id "." name))
                ,@(directory-tree dir (uiop:strcat file-base-id "." name)
                                  (uiop:strcat dir-base-id "." name)))
              out)))
    out))
      (multiple-value-bind (subdir-tree sub-component-names)
          (directory-tree dir component-name (uiop:strcat file-base-id "." dir-name) dir-id)
        (setf component-names (append sub-component-names component-names))
        (push subdir-tree out)))
    (values (nreverse out) component-names)))

(defun directory-files (pn)
  (let ((files (directory (merge-pathnames "*.*" pn)))
@@ -49,6 +65,9 @@
    out))

(defun build-wxs ()
  (multiple-value-bind (src-dir-tree src-dir-component-names)
      (directory-tree (merge-pathnames "lib/clpm/src/clpm/" *build-root-pathname*)
                      "CLPM_Src" "CLPM_SrcFile" "CLPM_SrcDir")
    `(("Wix" "xmlns" "http://schemas.microsoft.com/wix/2006/wi")
      (("Product" "Id" "*"
                  "Name" "Common Lisp Package Manager (CLPM)"
@@ -83,7 +102,7 @@
         (("Directory" "Id" "BaseFolder"
                       "Name" "CLPM")
          (("Directory" "Id" "VersionFolder"
                      "Name" "0.2.0")
                        "Name" "v0.2.0-alpha.1")
           (("Directory" "Id" "INSTALLDIR")
            (("Directory" "Id" "BINDIR"
                          "Name" "bin")
@@ -139,7 +158,8 @@
                             "Guid" "639DDC25-7C6D-4F7B-809E-A7989A3D15BE"
                             "DiskId" "1"
                             "Win64" "yes")
              ,@(directory-files (merge-pathnames "lib/clpm/src/clpm-groveler/" *build-root-pathname*)))))))))))
                ,@(directory-files (merge-pathnames "lib/clpm/src/clpm-groveler/" *build-root-pathname*))))
              ,src-dir-tree)))))))

       (("Feature" "Id" "Minimal"
                   "Title" "CLPM Executable"
@@ -149,6 +169,7 @@
        (("ComponentRef" "Id" "CLPM_Libs"))
        (("ComponentRef" "Id" "CLPM_Client"))
        (("ComponentRef" "Id" "CLPM_Groveler"))
        ,@(mapcar (lambda (id) `(("ComponentRef" "Id" ,id))) src-dir-component-names)
        (("Feature" "Id" "SetPath"
                    "Level" "1"
                    "Title" "Set Environment Variable: PATH")
@@ -161,7 +182,7 @@
                       "Value" "License.rtf"))
       (("Property" "Id" "WIXUI_INSTALLDIR"
                    "Value" "INSTALLDIR"))
     (("UIRef" "Id" "WixUI_FeatureTree")))))
       (("UIRef" "Id" "WixUI_FeatureTree"))))))

(defun write-wxs ()
  (with-open-file (s (merge-pathnames "clpm.wxs" *build-root-pathname*)