1(roswell:include "util-install-quicklisp")
2(defpackage :roswell.install.lispworks
3  (:use :cl :roswell.install :roswell.util))
4(in-package :roswell.install.lispworks)
5
6(defparameter *code*
7"(in-package \"CL-USER\")
8(load-all-patches)
9
10(defun main ()
11  (let ((args (rest sys:*line-arguments-list*)))
12    (loop :until (null args)
13          :for arg := (pop args)
14          :do (cond ((string= arg \"--eval\")
15                     (eval (read-from-string (pop args)))))))
16  (lw:start-tty-listener))
17
18(pushnew '(\"Main\" (:priority 60000000 :restart-action :continue) main)
19         mp:*initial-processes*)
20
21(save-image ~S
22            :console t
23            :multiprocessing t
24            :environment nil)")
25
26(defun get-option (argv option)
27  (second (member option argv :test #'string=)))
28
29(defun touch (file)
30  (open file :direction :probe :if-does-not-exist :create))
31
32(defun guess-version (lw-tar)
33  (let ((list (uiop:split-string (pathname-name lw-tar) :separator "-.")))
34    (let ((major (digit-char-p (char (first list) 2)))
35          (minor (digit-char-p (char (first list) 3)))
36          (arch (second list))
37          (os (third list)))
38      (values major minor arch os))))
39
40(defun build-lw-console (prefix lw-program)
41  (let ((lw-console (merge-pathnames "lw-console" prefix)))
42    (uiop:with-temporary-file (:stream stream :pathname lw-file)
43      (write-string (format nil *code* lw-console) stream)
44      :close-stream
45      (uiop:run-program (list lw-program "-build" (princ-to-string lw-file))))))
46
47(defun lw-runtime-name (lw-tar)
48  (multiple-value-bind (major minor arch os)
49      (guess-version lw-tar)
50    (format nil "lispworks-~D-~D-0-~A-~A"
51            major minor arch os)))
52
53(defun install-1 (prefix lw-tar lwdoc-tar)
54  (let ((target (ensure-directories-exist (make-pathname :defaults prefix :name nil :type nil))))
55    (if target
56        (progn
57          (expand lw-tar target)
58          (when lwdoc-tar
59            (expand lwdoc-tar target))
60          (let ((lwlicfile
61                  (multiple-value-bind (major minor)
62                      (guess-version lw-tar)
63                    (merge-pathnames (format nil "lib/~D-~D-0-0/config/lwlicense" major minor)
64                                     target))))
65            (touch lwlicfile)
66            (sb-posix:chmod (probe-file lwlicfile) #o666)))
67        (error "~S not exists" target))))
68
69(defun lw-install (argv)
70  (let* ((argv (getf argv :argv))
71         (lw-tar (get-option argv "--lw-tar"))
72         (lwdoc-tar (get-option argv "--lwdoc-tar"))
73         (serial-number (get-option argv "--lwlicenseserial"))
74         (key (get-option argv "--lwlicensekey"))
75         (prefix (merge-pathnames (make-pathname
76                                   :directory (list :relative "impls" (uname-m) (uname) "LispWorks"))
77                                  (homedir))))
78    (install-1 prefix lw-tar lwdoc-tar)
79    (let ((lw-program (merge-pathnames (lw-runtime-name lw-tar)
80                                       prefix)))
81      (uiop:run-program (list lw-program
82                              "--lwlicenseserial" serial-number
83                              "--lwlicensekey" key))
84      (build-lw-console prefix lw-program)))
85  (cons t argv))
86
87(defun help (argv)
88  (format t "lispworks install options~%")
89  (flet ((fmt (param default more)
90           (format t "--~A ~A~%~5T~A~%"
91                   param
92                   (or (and (not (null default))
93                            (not (eql default t))
94                            default)
95                       "")
96                   more)))
97    (fmt "lw-tar" nil "")
98    (fmt "lwdoc-tar" nil "")
99    (fmt "--lwlicenseserial" nil "")
100    (fmt "--lwlicensekey" nil ""))
101  (cons t argv))
102
103(defun lispworks (type)
104  (case type
105    (:help '(help))
106    (:install '(lw-install
107                setup))
108    (:list)))
109