code/install.lisp (4566 bytes)
1 (in-package #:clapt) 2 3 (defparameter *installed* ";;; Leave this line for clapt!") 4 (defparameter *logstream* t) 5 (defparameter *userstream* t) 6 7 (defun install (&key (sbclrc *sbclrc-path*) (core *core-path*) 8 (add '(:quicklisp :asdf))) 9 "Install clapt." 10 (when (not (installedp sbclrc)) 11 (write-to-init-file sbclrc add)) 12 (backup-core core (merge-pathnames #P".core.bak" sbclrc))) 13 14 (defun installedp (sbclrc-path) 15 "Determine if sbcl-librarian is installed in the .sbclrc." 16 (with-open-file (sbclrc sbclrc-path 17 :direction :input 18 :if-does-not-exist nil) 19 (when sbclrc (until sbclrc *installed*)))) 20 21 (defmacro warner (level datum &rest arguments) 22 "Use log to manage output." 23 ;; This is ugly like this because using variables for a format spec is 24 ;; considered bad style. 25 (case level 26 (error `(error ,datum ,@arguments)) 27 (warn `(warn ,datum ,@arguments)) 28 (log `(format *logstream* (concatenate 'string "LOG: " 29 ,datum) 30 ,@arguments)) 31 (user `(format *userstream* ,datum ,@arguments)) 32 (otherwise (error "Bad warning spec.")))) 33 34 ;; (backup-core #p"~/org/sbcl.org" #p"~/example.delete") 35 (defun backup-core (core backup) 36 "Save original core image." 37 (handler-case (copy-file core backup) 38 (:no-error (nothing) 39 (declare (ignore nothing)) 40 (warner user "~@{~a~}" 41 "Core was backed up from:" 42 (format nil "~%") 43 core 44 (format nil "~%to:~%") 45 backup 46 (format nil "~%"))) 47 (file-error (path-obj) 48 (let ((fail (file-error-pathname path-obj))) 49 (cond ((uiop:pathname-equal fail core) 50 (warner warn "~@{~a~}" 51 "The core does not exist, sbcl will have" 52 " to be started " 53 (format nil "with the:~%--core \"") 54 fail 55 (format nil "\"~%option to enable the ") 56 (format nil "libraries core.~%"))) 57 ((uiop:pathname-equal fail backup) 58 (warner log "~@{~a~}" 59 "The backup was aborted because there already is" 60 (format nil " one there at:~%") 61 fail 62 (format nil "~%and it is ") 63 (format nil "probably the vanilla one.~%"))) 64 (t (warner error "~@{~a~}" 65 "Unexpected backup failure. Submit a bug report:" 66 (format nil "~%core: ") core 67 (format nil "~%backup: ") backup 68 (format nil "~%failure path: ") fail 69 (format nil "~%")))))))) 70 71 (defun write-to-init-file (sbclrc systema) 72 "Common Lisp code in the init file for cl-apt to install itself if not 73 installed. Provides persistence even when a new version is built." 74 (with-open-file (s sbclrc 75 :direction :output 76 :if-exists :append 77 :if-does-not-exist :create) 78 (when (not (installedp sbclrc)) 79 (self-install s) 80 (parameterize s systema) 81 (init s sbclrc)))) 82 83 (defun init (stream init) 84 (print 85 `(setf *init-file* ,init) 86 stream)) 87 88 89 (defun manager-packages-variable (manager) 90 (intern (concatenate 'string "*" (symbol-name manager) "-PACKAGES*") 91 (find-package :clapt))) 92 (defun manager-packages (manager) 93 (symbol-value (manager-packages-variable manager))) 94 (defun pushnew-package (manager package) 95 ;; Needs EVAL because the interface -- anaphoric interning -- is not very 96 ;; good. 97 (eval (let ((packages (manager-packages manager))) 98 `(setf ,(manager-packages-variable manager) 99 ',(pushnew package packages))))) 100 ;; (let ((q :quicklisp)) (pushnew-package q 'bogus)) 101 ;; (manager-packages :quicklisp) 102 103 (defun package-parameter (packages manager) 104 `(setf ,(manager-packages-variable manager) 105 ',packages)) 106 ;; (package-parameter '(petalisp) :quicklisp) 107 108 (defun self-install (sbclrc) 109 (declare (stream sbclrc)) 110 (format sbclrc "~%~A~%" "#-clapt") 111 (prin1 '(asdf:load-system :clapt) sbclrc) 112 (format sbclrc "~%~A~%" "#-clapt") 113 (prin1 '(clapt:update) sbclrc) 114 (format sbclrc "~%") 115 (format sbclrc "~%~A~%" *installed*)) 116 117 (defun parameterize (sbclrc systema) 118 (declare (stream sbclrc)) 119 (mapcar #'(lambda (code) (print code sbclrc)) 120 (loop for s in systema 121 collect (package-parameter nil s))))