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