|
| 1 | +;; Copyright (c) 2014 Zachary Beane <zach@quicklisp.org> |
| 2 | + |
| 3 | +;; Permission is hereby granted, free of charge, to any person obtaining a copy |
| 4 | +;; of this software and associated documentation files (the "Software"), to deal |
| 5 | +;; in the Software without restriction, including without limitation the rights |
| 6 | +;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell |
| 7 | +;; copies of the Software, and to permit persons to whom the Software is |
| 8 | +;; furnished to do so, subject to the following conditions: |
| 9 | + |
| 10 | +;; The above copyright notice and this permission notice shall be included in |
| 11 | +;; all copies or substantial portions of the Software. |
| 12 | + |
| 13 | +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR |
| 14 | +;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, |
| 15 | +;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE |
| 16 | +;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER |
| 17 | +;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, |
| 18 | +;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN |
| 19 | +;; THE SOFTWARE. |
| 20 | + |
| 21 | +;;; Commentary: |
| 22 | +;; |
| 23 | +;; Copied to get rid the `(qicklisp:setup)' call. |
| 24 | +;; Whenever the client is updated the setup.lisp is replaced |
| 25 | +;; and contains the call to setup. |
| 26 | + |
| 27 | +(defpackage #:ql-setup |
| 28 | + (:use #:cl) |
| 29 | + (:export #:*quicklisp-home* |
| 30 | + #:qmerge |
| 31 | + #:qenough)) |
| 32 | + |
| 33 | +(in-package #:ql-setup) |
| 34 | + |
| 35 | +(unless *load-truename* |
| 36 | + (error "This file must be LOADed to set up quicklisp.")) |
| 37 | + |
| 38 | +(defvar *quicklisp-home* |
| 39 | + (make-pathname :name nil :type nil |
| 40 | + :defaults (let ((qlhome "~/quicklisp/")) |
| 41 | + (if (probe-file qlhome) |
| 42 | + qlhome |
| 43 | + (error "Quicklisp not installed to |
| 44 | + default location. Please set |
| 45 | + *quicklisp-home* manually and |
| 46 | + retry"))))) |
| 47 | + |
| 48 | +(defun qmerge (pathname) |
| 49 | + "Return PATHNAME merged with the base Quicklisp directory." |
| 50 | + (merge-pathnames pathname *quicklisp-home*)) |
| 51 | + |
| 52 | +(defun qenough (pathname) |
| 53 | + (enough-namestring pathname *quicklisp-home*)) |
| 54 | + |
| 55 | +;;; ASDF is a hard requirement of quicklisp. Make sure it's either |
| 56 | +;;; already loaded or load it from quicklisp's bundled version. |
| 57 | + |
| 58 | +(defvar *required-asdf-version* "3.0") |
| 59 | + |
| 60 | +;;; Put ASDF's fasls in a separate directory |
| 61 | + |
| 62 | +(defun implementation-signature () |
| 63 | + "Return a string suitable for discriminating different |
| 64 | +implementations, or similar implementations with possibly-incompatible |
| 65 | +FASLs." |
| 66 | + ;; XXX Will this have problems with stuff like threads vs |
| 67 | + ;; non-threads fasls? |
| 68 | + (let ((*print-pretty* nil)) |
| 69 | + (format nil "lisp-implementation-type: ~A~%~ |
| 70 | + lisp-implementation-version: ~A~%~ |
| 71 | + machine-type: ~A~%~ |
| 72 | + machine-version: ~A~%" |
| 73 | + (lisp-implementation-type) |
| 74 | + (lisp-implementation-version) |
| 75 | + (machine-type) |
| 76 | + (machine-version)))) |
| 77 | + |
| 78 | +(defun dumb-string-hash (string) |
| 79 | + "Produce a six-character hash of STRING." |
| 80 | + (let ((hash #xD13CCD13)) |
| 81 | + (loop for char across string |
| 82 | + for value = (char-code char) |
| 83 | + do |
| 84 | + (setf hash (logand #xFFFFFFFF |
| 85 | + (logxor (ash hash 5) |
| 86 | + (ash hash -27) |
| 87 | + value)))) |
| 88 | + (subseq (format nil "~(~36,6,'0R~)" (mod hash 88888901)) |
| 89 | + 0 6))) |
| 90 | + |
| 91 | +(defun asdf-fasl-pathname () |
| 92 | + "Return a pathname suitable for storing the ASDF FASL, separated |
| 93 | +from ASDF FASLs from incompatible implementations. Also, save a file |
| 94 | +in the directory with the implementation signature, if it doesn't |
| 95 | +already exist." |
| 96 | + (let* ((implementation-signature (implementation-signature)) |
| 97 | + (original-fasl (compile-file-pathname (qmerge "asdf.lisp"))) |
| 98 | + (fasl |
| 99 | + (qmerge (make-pathname |
| 100 | + :defaults original-fasl |
| 101 | + :directory |
| 102 | + (list :relative |
| 103 | + "cache" |
| 104 | + "asdf-fasls" |
| 105 | + (dumb-string-hash implementation-signature))))) |
| 106 | + (signature-file (merge-pathnames "signature.txt" fasl))) |
| 107 | + (ensure-directories-exist fasl) |
| 108 | + (unless (probe-file signature-file) |
| 109 | + (with-open-file (stream signature-file :direction :output) |
| 110 | + (write-string implementation-signature stream))) |
| 111 | + fasl)) |
| 112 | + |
| 113 | +(defun ensure-asdf-loaded () |
| 114 | + "Try several methods to make sure that a sufficiently-new ASDF is |
| 115 | +loaded: first try (require \"asdf\"), then loading the ASDF FASL, then |
| 116 | +compiling asdf.lisp to a FASL and then loading it." |
| 117 | + (let ((source (qmerge "asdf.lisp"))) |
| 118 | + (labels ((asdf-symbol (name) |
| 119 | + (let ((asdf-package (find-package '#:asdf))) |
| 120 | + (when asdf-package |
| 121 | + (find-symbol (string name) asdf-package)))) |
| 122 | + (version-satisfies (version) |
| 123 | + (let ((vs-fun (asdf-symbol '#:version-satisfies)) |
| 124 | + (vfun (asdf-symbol '#:asdf-version))) |
| 125 | + (when (and vs-fun vfun |
| 126 | + (fboundp vs-fun) |
| 127 | + (fboundp vfun)) |
| 128 | + (funcall vs-fun (funcall vfun) version))))) |
| 129 | + (block nil |
| 130 | + (macrolet ((try (&body asdf-loading-forms) |
| 131 | + `(progn |
| 132 | + (handler-bind ((warning #'muffle-warning)) |
| 133 | + (ignore-errors |
| 134 | + ,@asdf-loading-forms)) |
| 135 | + (when (version-satisfies *required-asdf-version*) |
| 136 | + (return t))))) |
| 137 | + (try) |
| 138 | + (try (require "asdf")) |
| 139 | + (let ((fasl (asdf-fasl-pathname))) |
| 140 | + (try (load fasl :verbose nil)) |
| 141 | + (try (load (compile-file source :verbose nil :output-file fasl)))) |
| 142 | + (error "Could not load ASDF ~S or newer" *required-asdf-version*)))))) |
| 143 | + |
| 144 | +(ensure-asdf-loaded) |
| 145 | + |
| 146 | +;;; |
| 147 | +;;; Quicklisp sometimes must upgrade ASDF. Ugrading ASDF will blow |
| 148 | +;;; away existing ASDF methods, so e.g. FASL recompilation :around |
| 149 | +;;; methods would be lost. This config file will make it possible to |
| 150 | +;;; ensure ASDF can be configured before loading Quicklisp itself via |
| 151 | +;;; ASDF. Thanks to Nikodemus Siivola for pointing out this issue. |
| 152 | +;;; |
| 153 | + |
| 154 | +(let ((asdf-init (probe-file (qmerge "asdf-config/init.lisp")))) |
| 155 | + (when asdf-init |
| 156 | + (with-simple-restart (skip "Skip loading ~S" asdf-init) |
| 157 | + (load asdf-init :verbose nil :print nil)))) |
| 158 | + |
| 159 | +(push (qmerge "quicklisp/") asdf:*central-registry*) |
| 160 | + |
| 161 | +(let ((*compile-print* nil) |
| 162 | + (*compile-verbose* nil) |
| 163 | + (*load-verbose* nil) |
| 164 | + (*load-print* nil)) |
| 165 | + (asdf:oos 'asdf:load-op "quicklisp" :verbose nil)) |
0 commit comments